haskoin-store 0.22.5 → 0.23.0
raw patch · 16 files changed
+2085/−1864 lines, 16 files
Files
- CHANGELOG.md +9/−0
- app/Main.hs +6/−0
- haskoin-store.cabal +2/−2
- src/Haskoin/Store.hs +1/−3
- src/Haskoin/Store/BlockStore.hs +9/−12
- src/Haskoin/Store/Cache.hs +202/−131
- src/Haskoin/Store/Common.hs +1267/−1422
- src/Haskoin/Store/Database/Memory.hs +37/−21
- src/Haskoin/Store/Database/Reader.hs +24/−8
- src/Haskoin/Store/Database/Types.hs +24/−27
- src/Haskoin/Store/Database/Writer.hs +22/−6
- src/Haskoin/Store/Logic.hs +131/−125
- src/Haskoin/Store/Manager.hs +10/−4
- src/Haskoin/Store/Web.hs +61/−53
- test/Haskoin/Store/CommonSpec.hs +279/−50
- test/Haskoin/StoreSpec.hs +1/−0
CHANGELOG.md view
@@ -4,6 +4,15 @@ 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.23.0+### Added+- Support for Redis transactions.+- Use a smaller initial gap for empty xpubs.++### Changed+- Remove custom JSON encoding class.+- Refactor and code simplification.+ ## 0.22.5 ### Fixed - Cache was being completely pruned.
app/Main.hs view
@@ -121,6 +121,11 @@ metavar "MAXGAP" <> long "maxgap" <> help "Max gap for xpub queries" <> showDefault <> value (maxLimitGap def)+ maxLimitInitialGap <-+ option auto $+ metavar "INITGAP" <> long "initgap" <> help "Max gap for empty xpub" <>+ showDefault <>+ value (maxLimitInitialGap def) blockTimeout <- option auto $ metavar "BLOCKSECONDS" <> long "blocktimeout" <>@@ -233,6 +238,7 @@ then Just redisurl else Nothing , storeConfGap = maxLimitGap limits+ , storeConfInitialGap = maxLimitInitialGap limits , storeConfCacheMin = cachemin , storeConfMaxKeys = redismax }
haskoin-store.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 2cd6a8e51e70eea8c49ec7ce774c829045c2c0df5f1727af547d6194e05db79c+-- hash: 48de78f8abbf3329c05bf1a04f570321fafd1840f48c22f42955091321a6dbca name: haskoin-store-version: 0.22.5+version: 0.23.0 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Store and index Bitcoin or Bitcoin Cash blocks, transactions, balances and unspent outputs. All data is available via REST API in JSON or binary format.
src/Haskoin/Store.hs view
@@ -12,6 +12,7 @@ , XPubSummary (..) , XPubUnspent (..) , DeriveType (..)+ , NetWrap (..) , UnixTime , Limit , Offset@@ -24,9 +25,6 @@ , transactionData , fromTransaction , toTransaction-- , BinSerial (..)- , JsonSerial (..) , blockAtOrBefore , confirmed
src/Haskoin/Store/BlockStore.hs view
@@ -110,6 +110,9 @@ runReaderT f db instance MonadIO m => StoreRead (ReaderT BlockRead m) where+ getMaxGap = runRocksDB getMaxGap+ getInitialGap = runRocksDB getInitialGap+ getNetwork = runRocksDB getNetwork getBestBlock = runRocksDB getBestBlock getBlocksAtHeight = runRocksDB . getBlocksAtHeight getBlock = runRocksDB . getBlock@@ -141,8 +144,7 @@ BlockRead {mySelf = inboxToMailbox inbox, myConfig = cfg, myPeer = pb} where ini = do- net <- asks (blockConfNet . myConfig)- runImport (initBest net) >>= \case+ runImport initBest >>= \case Left e -> do $(logErrorS) "BlockStore" $ "Could not initialize block store: " <> fromString (show e)@@ -179,8 +181,7 @@ void . runMaybeT $ do checkpeer blocknode <- getblocknode- net <- asks (blockConfNet . myConfig)- lift (runImport (importBlock net block blocknode)) >>= \case+ lift (runImport (importBlock block blocknode)) >>= \case Right deletedtxids -> do listener <- asks (blockConfListener . myConfig) $(logInfoS) "BlockStore" $ "Best block indexed: " <> hexhash@@ -229,8 +230,7 @@ isInSync >>= \sync -> when sync $ do now <- fromIntegral . systemSeconds <$> liftIO getSystemTime- net <- asks (blockConfNet . myConfig)- runImport (newMempoolTx net tx now) >>= \case+ runImport (newMempoolTx tx now) >>= \case Right (Just deleted) -> do l <- blockConfListener <$> asks myConfig $(logInfoS) "BlockStore" $@@ -246,7 +246,6 @@ isInSync >>= \sync -> when sync $ do now <- fromIntegral . systemSeconds <$> liftIO getSystemTime- net <- asks (blockConfNet . myConfig) old <- getOldOrphans now case old of [] -> return ()@@ -264,7 +263,7 @@ " orphan transactions" ops <- zip (map snd orphans) <$>- mapM (runImport . uncurry (importOrphan net)) orphans+ mapM (runImport . uncurry importOrphan) orphans let tths = [ (txHash tx, hs) | (tx, emths) <- ops@@ -346,9 +345,8 @@ deletetxs old = do $(logInfoS) "BlockStore" $ "Removing " <> cs (show (length old)) <> " old mempool transactions"- net <- asks (blockConfNet . myConfig) forM_ old $ \txid ->- runImport (deleteTx net True txid) >>= \case+ runImport (deleteTx True txid) >>= \case Left _ -> return () Right txids -> do listener <- asks (blockConfListener . myConfig)@@ -447,8 +445,7 @@ $(logErrorS) "BlockStore" $ "Reverting best block: " <> blockHashToHex bestblockhash resetPeer- net <- asks (blockConfNet . myConfig)- lift (runImport (revertBlock net bestblockhash)) >>= \case+ lift (runImport (revertBlock bestblockhash)) >>= \case Left e -> do $(logErrorS) "BlockStore" $ "Could not revert best block: " <> cs (show e)
src/Haskoin/Store/Cache.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-}@@ -37,16 +38,17 @@ import Data.List (nub, sort) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map-import Data.Maybe (catMaybes, fromJust, mapMaybe)+import Data.Maybe (catMaybes, mapMaybe) import Data.Serialize (decode, encode) import Data.Serialize (Serialize) import Data.String.Conversions (cs) import Data.Time.Clock.System (getSystemTime, systemSeconds)-import Data.Word (Word32, Word64)-import Database.Redis (Connection, Redis, Reply,+import Data.Word (Word64)+import Database.Redis (Connection, Queued, Redis, RedisCtx,+ RedisTx, Reply, TxResult (..), checkedConnect, defaultConnectInfo,- hgetall, parseConnectInfo, runRedis,- runRedis, zadd, zrangeWithscores,+ hgetall, parseConnectInfo, watch,+ zadd, zrangeWithscores, zrangebyscoreWithscoresLimit, zrem) import qualified Database.Redis as Redis import GHC.Generics (Generic)@@ -77,19 +79,33 @@ import UnliftIO (Exception, MonadIO, MonadUnliftIO, liftIO, throwIO) -type RedisReply a = Redis (Either Reply a)+runRedis :: MonadIO m => Redis (Either Reply a) -> CacheT m a+runRedis action =+ asks cacheConn >>= \conn ->+ liftIO (Redis.runRedis conn action) >>= \case+ Right x -> return x+ Left e -> throwIO (RedisError e) -runRedisReply :: MonadIO m => RedisReply a -> CacheT m a-runRedisReply action =+runRedisTx ::+ MonadIO m+ => Redis (Either Reply b)+ -> (b -> RedisTx (Queued a))+ -> CacheT m a+runRedisTx pre action = asks cacheConn >>= \conn ->- liftIO (runRedis conn action) >>= \case+ liftIO (Redis.runRedis conn go) >>= \case+ TxSuccess x -> return x+ TxAborted -> runRedisTx pre action+ TxError e -> throwIO (RedisTxError e)+ where+ go =+ pre >>= \case Left e -> throwIO (RedisError e)- Right x -> return x+ Right y -> Redis.multiExec (action y) data CacheConfig = CacheConfig { cacheConn :: !Connection- , cacheGap :: !Word32 , cacheMin :: !Int , cacheMax :: !Integer , cacheChain :: !Chain@@ -99,7 +115,8 @@ data CacheError = RedisError Reply- | LogicError String+ | RedisTxError !String+ | LogicError !String deriving (Show, Eq, Generic, NFData, Exception) connectRedis :: MonadIO m => String -> m Connection@@ -113,6 +130,7 @@ liftIO (checkedConnect conninfo) instance (MonadLoggerIO m, StoreRead m) => StoreRead (CacheT m) where+ getNetwork = lift getNetwork getBestBlock = lift getBestBlock getBlocksAtHeight = lift . getBlocksAtHeight getBlock = lift . getBlock@@ -132,7 +150,8 @@ xPubBals = getXPubBalances xPubUnspents = getXPubUnspents xPubTxs = getXPubTxs- getMaxGap = asks cacheGap+ getMaxGap = lift getMaxGap+ getInitialGap = lift getInitialGap withCache :: StoreRead m => CacheConfig -> CacheT m a -> m a withCache s f = runReaderT f s@@ -227,21 +246,23 @@ fst <$> newXPubC xpub isXPubCached :: MonadIO m => XPubSpec -> CacheT m Bool-isXPubCached = runRedisReply . redisIsXPubCached+isXPubCached = runRedis . redisIsXPubCached -redisIsXPubCached :: XPubSpec -> RedisReply Bool+redisIsXPubCached :: RedisCtx m f => XPubSpec -> m (f Bool) redisIsXPubCached xpub = Redis.exists (balancesPfx <> encode xpub) +redisWatchXPubCached :: [XPubSpec] -> Redis (Either Reply [Bool])+redisWatchXPubCached [] = return (pure [])+redisWatchXPubCached xpubs = do+ w <- watch $ map ((balancesPfx <>) . encode) xpubs+ ys <- sequence <$> forM xpubs redisIsXPubCached+ return $ w >> ys+ cacheGetXPubBalances :: MonadIO m => XPubSpec -> CacheT m [XPubBal] cacheGetXPubBalances xpub = do- now <- systemSeconds <$> liftIO getSystemTime- runRedisReply $ do- bals <- redisGetXPubBalances xpub- x <-- case bals of- Right (_:_) -> touchKeys now [xpub]- _ -> return (pure 0)- return $ x >> bals+ bals <- runRedis $ redisGetXPubBalances xpub+ touchKeys [xpub]+ return bals cacheGetXPubTxs :: MonadIO m@@ -251,14 +272,9 @@ -> Maybe Limit -> CacheT m [BlockTx] cacheGetXPubTxs xpub start offset limit = do- now <- systemSeconds <$> liftIO getSystemTime- runRedisReply $ do- txs <- redisGetXPubTxs xpub start offset limit- x <-- case txs of- Right (_:_) -> touchKeys now [xpub]- _ -> return (pure 0)- return $ x >> txs+ txs <- runRedis $ redisGetXPubTxs xpub start offset limit+ touchKeys [xpub]+ return txs cacheGetXPubUnspents :: MonadIO m@@ -268,13 +284,11 @@ -> Maybe Limit -> CacheT m [(BlockRef, OutPoint)] cacheGetXPubUnspents xpub start offset limit = do- now <- systemSeconds <$> liftIO getSystemTime- runRedisReply $ do- x <- touchKeys now [xpub]- uns <- redisGetXPubUnspents xpub start offset limit- return $ x >> uns+ uns <- runRedis $ redisGetXPubUnspents xpub start offset limit+ touchKeys [xpub]+ return uns -redisGetXPubBalances :: XPubSpec -> RedisReply [XPubBal]+redisGetXPubBalances :: (Functor f, RedisCtx m f) => XPubSpec -> m (f [XPubBal]) redisGetXPubBalances xpub = getAllFromMap (balancesPfx <> encode xpub) >>= return . fmap (sort . map (uncurry f))@@ -282,11 +296,12 @@ f p b = XPubBal {xPubBalPath = p, xPubBal = b} redisGetXPubTxs ::- XPubSpec+ (Applicative f, RedisCtx m f)+ => XPubSpec -> Maybe BlockRef -> Offset -> Maybe Limit- -> RedisReply [BlockTx]+ -> m (f [BlockTx]) redisGetXPubTxs xpub start offset limit = do xs <- getFromSortedSet@@ -299,11 +314,12 @@ f t s = BlockTx {blockTxHash = t, blockTxBlock = scoreBlockRef s} redisGetXPubUnspents ::- XPubSpec+ (Applicative f, RedisCtx m f)+ => XPubSpec -> Maybe BlockRef -> Offset -> Maybe Limit- -> RedisReply [(BlockRef, OutPoint)]+ -> m (f [(BlockRef, OutPoint)]) redisGetXPubUnspents xpub start offset limit = do xs <- getFromSortedSet@@ -336,12 +352,12 @@ p = fromIntegral (m .&. 0x03ffffff) getFromSortedSet ::- Serialize a+ (Applicative f, RedisCtx m f, Serialize a) => ByteString -> Maybe Double -> Integer -> Maybe Integer- -> RedisReply [(a, Double)]+ -> m (f [(a, Double)]) getFromSortedSet key Nothing offset Nothing = do xs <- zrangeWithscores key offset (-1) return $ do@@ -377,7 +393,10 @@ ys <- map (\(x, s) -> (, s) <$> decode x) <$> xs return (rights ys) -getAllFromMap :: (Serialize k, Serialize v) => ByteString -> RedisReply [(k, v)]+getAllFromMap ::+ (Functor f, RedisCtx m f, Serialize k, Serialize v)+ => ByteString+ -> m (f [(k, v)]) getAllFromMap n = do fxs <- hgetall n return $ do@@ -434,7 +453,7 @@ pruneDB :: (MonadLoggerIO m, StoreRead m) => CacheT m Integer pruneDB = do x <- asks cacheMax- s <- runRedisReply Redis.dbsize+ s <- runRedis Redis.dbsize if s > x then do n <- flush (s - x)@@ -444,20 +463,25 @@ else return 0 where flush n =- runRedisReply $ case min 1000 (n `div` 64) of- 0 -> return (pure 0)+ 0 -> return 0 x -> do- eks <- getFromSortedSet maxKey Nothing 0 (Just x)- case eks of- Right ks -> do- xs <- sequence <$> forM (map fst ks) redisDelXPubKeys- return $ xs >>= return . sum- Left _ -> return $ eks >> return 0+ ks <-+ fmap (map fst) . runRedis $+ getFromSortedSet maxKey Nothing 0 (Just x)+ delXPubKeys ks -touchKeys :: Real a => a -> [XPubSpec] -> RedisReply Integer-touchKeys _ [] = return (pure 0)-touchKeys now xpubs =+touchKeys :: MonadIO m => [XPubSpec] -> CacheT m Integer+touchKeys xpubs = do+ now <- systemSeconds <$> liftIO getSystemTime+ runRedisTx (redisWatchXPubCached xpubs) $ \ys -> do+ let xpubs' = map fst . filter snd $ zip xpubs ys+ redisTouchKeys now xpubs'++redisTouchKeys ::+ (Applicative f, RedisCtx m f, Real a) => a -> [XPubSpec] -> m (f Integer)+redisTouchKeys _ [] = return (pure 0)+redisTouchKeys now xpubs = Redis.zadd maxKey $ map ((realToFrac now, ) . encode) xpubs cacheWriterReact ::@@ -490,20 +514,20 @@ "Not caching xpub with " <> cs (show n) <> " used addresses" return (bals, False) where+ op XPubUnspent {xPubUnspent = u} = (unspentPoint u, unspentBlock u) go bals = do utxo <- lift $ xPubUnspents xpub Nothing 0 Nothing xtxs <- lift $ xPubTxs xpub Nothing 0 Nothing now <- systemSeconds <$> liftIO getSystemTime- runRedisReply $ do- x <- redisAddXPubBalances xpub bals- y <-- redisAddXPubUnspents- xpub- (map ((\u -> (unspentPoint u, unspentBlock u)) . xPubUnspent)- utxo)- z <- redisAddXPubTxs xpub xtxs- a <- touchKeys now [xpub]- return $ x >> y >> z >> a >> return ()+ runRedisTx (redisWatchXPubCached [xpub]) $ \ts ->+ if and ts+ then return (pure ())+ else do+ x <- redisAddXPubBalances xpub bals+ y <- redisAddXPubUnspents xpub (map op utxo)+ z <- redisAddXPubTxs xpub xtxs+ t <- redisTouchKeys now [xpub]+ return $ x >> y >> z >> t >> pure () newBlockC :: (MonadLoggerIO m, StoreRead m) => CacheT m () newBlockC =@@ -606,30 +630,37 @@ cacheGetAddrsInfo alladdrs balmap <- Map.fromList . zipWith (,) alladdrs <$>- mapM (lift . getBalance) alladdrs+ mapM (lift . getBalance) (Map.keys addrmap) unspentmap <- Map.fromList . catMaybes . zipWith (\p -> fmap (p, )) allops <$> lift (mapM getUnspent allops) gap <- getMaxGap now <- systemSeconds <$> liftIO getSystemTime newaddrs <-- runRedisReply $ do- x <- redisImportMultiTx addrmap unspentmap txs- y <- redisUpdateBalances addrmap balmap- z <- touchKeys now (allxpubs addrmap)- newaddrs <- redisGetNewAddrs gap addrmap- return $ x >> y >> z >> newaddrs+ runRedisTx (redisWatchXPubCached (allxpubs addrmap)) $ \ys ->+ if or ys+ then do+ let xpubs = map fst . filter snd $ zip (allxpubs addrmap) ys+ addrmap' = faddrmap xpubs addrmap+ x <- redisImportMultiTx addrmap' unspentmap txs+ y <- redisUpdateBalances addrmap' balmap+ z <- redisTouchKeys now (allxpubs addrmap')+ n <- redisGetNewAddrs gap addrmap'+ return $ x >> y >> z >> n+ else return (pure Map.empty) unless (Map.null newaddrs) $ cacheAddAddresses newaddrs where+ faddrmap xpubs = Map.filter ((`elem` xpubs) . addressXPubSpec) allops = map snd $ concatMap txInputs txs <> concatMap txOutputs txs alladdrs = nub . map fst $ concatMap txInputs txs <> concatMap txOutputs txs allxpubs addrmap = nub . map addressXPubSpec $ Map.elems addrmap redisImportMultiTx ::- Map Address AddressXPub+ (Monad f, RedisCtx m f)+ => Map Address AddressXPub -> Map OutPoint Unspent -> [TxData]- -> RedisReply ()+ -> m (f ()) redisImportMultiTx addrmap unspentmap txs = do xs <- mapM importtxentries txs return $ sequence xs >> return ()@@ -683,14 +714,16 @@ utxos td = txOutputs td redisUpdateBalances ::- Map Address AddressXPub -> Map Address Balance -> RedisReply ()-redisUpdateBalances addrmap balmap = do- bs <-- forM (Map.keys addrmap) $ \a ->- let ainfo = fromJust (Map.lookup a addrmap)- bal = fromJust (Map.lookup a balmap)- in redisAddXPubBalances (addressXPubSpec ainfo) [xpubbal ainfo bal]- return $ sequence bs >> return ()+ (Monad f, RedisCtx m f)+ => Map Address AddressXPub+ -> Map Address Balance+ -> m (f ())+redisUpdateBalances addrmap balmap =+ fmap (void . sequence) . forM (Map.keys addrmap) $ \a ->+ case (Map.lookup a addrmap, Map.lookup a balmap) of+ (Just ainfo, Just bal) ->+ redisAddXPubBalances (addressXPubSpec ainfo) [xpubbal ainfo bal]+ _ -> return (pure ()) where xpubbal ainfo bal = XPubBal {xPubBalPath = addressXPubPath ainfo, xPubBal = bal}@@ -701,7 +734,7 @@ -> CacheT m () cacheAddAddresses addrmap = do gap <- getMaxGap- newmap <- runRedisReply (redisGetNewAddrs gap addrmap)+ newmap <- runRedis (redisGetNewAddrs gap addrmap) balmap <- Map.fromList <$> mapM getbal (Map.keys newmap) utxomap <- Map.fromList <$> mapM getutxo (Map.keys newmap) txmap <- Map.fromList <$> mapM gettxmap (Map.keys newmap)@@ -709,57 +742,74 @@ xpubbals = getxpubbals newmap balmap unspents = getunspents newmap utxomap txs = gettxs newmap txmap+ xpubs = map addressXPubSpec (Map.elems addrmap) newaddrs <-- runRedisReply $ do+ runRedisTx (redisWatchXPubCached xpubs) $ \ys -> do+ let xpubs' = map fst . filter snd $ zip xpubs ys+ xpubbals' =+ HashMap.filterWithKey (\x _ -> x `elem` xpubs') xpubbals+ unspents' =+ HashMap.filterWithKey (\x _ -> x `elem` xpubs') unspents+ txs' = HashMap.filterWithKey (\x _ -> x `elem` xpubs') txs+ notnulls' =+ Map.filter (\x -> addressXPubSpec x `elem` xpubs') notnulls x' <-- forM (HashMap.toList xpubbals) $ \(x, bs) ->+ forM (HashMap.toList xpubbals') $ \(x, bs) -> redisAddXPubBalances x bs y' <-- forM (HashMap.toList unspents) $ \(x, us) ->+ forM (HashMap.toList unspents') $ \(x, us) -> redisAddXPubUnspents x (map uns us)- z' <- forM (HashMap.toList txs) $ \(x, ts) -> redisAddXPubTxs x ts- newaddrs <- redisGetNewAddrs gap notnulls+ z' <- forM (HashMap.toList txs') $ \(x, ts) -> redisAddXPubTxs x ts+ new <- redisGetNewAddrs gap notnulls' return $ do _ <- sequence x' _ <- sequence y' _ <- sequence z'- newaddrs+ new unless (null newaddrs) $ cacheAddAddresses newaddrs where uns u = (unspentPoint u, unspentBlock u) gettxs newmap txmap = let f a ts =- let i = fromJust (Map.lookup a newmap)- in (addressXPubSpec i, ts)+ case Map.lookup a newmap of+ Nothing -> Nothing+ Just i -> Just (addressXPubSpec i, ts) g m (x, ts) = HashMap.insertWith (<>) x ts m- in foldl g HashMap.empty (map (uncurry f) (Map.toList txmap))+ in foldl g HashMap.empty (mapMaybe (uncurry f) (Map.toList txmap)) getunspents newmap utxomap = let f a us =- let i = fromJust (Map.lookup a newmap)- in (addressXPubSpec i, us)+ case Map.lookup a newmap of+ Nothing -> Nothing+ Just i -> Just (addressXPubSpec i, us) g m (x, us) = HashMap.insertWith (<>) x us m- in foldl g HashMap.empty (map (uncurry f) (Map.toList utxomap))+ in foldl g HashMap.empty (mapMaybe (uncurry f) (Map.toList utxomap)) getxpubbals newmap balmap = let f a b =- let i = fromJust (Map.lookup a newmap)- in ( addressXPubSpec i- , XPubBal {xPubBal = b, xPubBalPath = addressXPubPath i})+ case Map.lookup a newmap of+ Nothing -> Nothing+ Just i ->+ Just+ ( addressXPubSpec i+ , XPubBal+ {xPubBal = b, xPubBalPath = addressXPubPath i}) g m (x, b) = HashMap.insertWith (<>) x [b] m- in foldl g HashMap.empty (map (uncurry f) (Map.toList balmap))+ in foldl g HashMap.empty (mapMaybe (uncurry f) (Map.toList balmap)) getnotnull newmap balmap = let f a _ =- let i = fromJust (Map.lookup a newmap)- in (a, i)- in Map.fromList . map (uncurry f) . Map.toList $+ case Map.lookup a newmap of+ Nothing -> Nothing+ Just i -> Just (a, i)+ in Map.fromList . mapMaybe (uncurry f) . Map.toList $ Map.filter (not . nullBalance) balmap getbal a = (a, ) <$> lift (getBalance a) getutxo a = (a, ) <$> lift (getAddressUnspents a Nothing Nothing) gettxmap a = (a, ) <$> lift (getAddressTxs a Nothing Nothing) redisGetNewAddrs ::- KeyIndex+ (Monad f, RedisCtx m f)+ => KeyIndex -> Map Address AddressXPub- -> RedisReply (Map Address AddressXPub)+ -> m (f (Map Address AddressXPub)) redisGetNewAddrs gap addrmap = xbalmap >>= \xbalmap' -> return $ do@@ -808,36 +858,50 @@ importMultiTxC txs cacheGetMempool :: MonadIO m => CacheT m [BlockTx]-cacheGetMempool = runRedisReply redisGetMempool+cacheGetMempool = runRedis redisGetMempool cacheGetHead :: MonadIO m => CacheT m (Maybe BlockHash)-cacheGetHead = runRedisReply redisGetHead+cacheGetHead = runRedis redisGetHead cacheSetHead :: MonadIO m => BlockHash -> CacheT m ()-cacheSetHead bh = runRedisReply (redisSetHead bh) >> return ()+cacheSetHead bh = runRedis (redisSetHead bh) >> return () cacheGetAddrsInfo :: MonadIO m => [Address] -> CacheT m [Maybe AddressXPub]-cacheGetAddrsInfo as = runRedisReply (redisGetAddrsInfo as)+cacheGetAddrsInfo as = runRedis (redisGetAddrsInfo as) -redisAddToMempool :: BlockTx -> Redis (Either Reply Integer)+redisAddToMempool :: RedisCtx m f => BlockTx -> m (f Integer) redisAddToMempool btx = zadd mempoolSetKey [(blockRefScore (blockTxBlock btx), encode (blockTxHash btx))] -redisRemFromMempool :: TxHash -> RedisReply Integer+redisRemFromMempool :: RedisCtx m f => TxHash -> m (f Integer) redisRemFromMempool th = zrem mempoolSetKey [encode th] -redisSetAddrInfo :: Address -> AddressXPub -> RedisReply Redis.Status+redisSetAddrInfo :: RedisCtx m f => Address -> AddressXPub -> m (f Redis.Status) redisSetAddrInfo a i = Redis.set (addrPfx <> encode a) (encode i) -redisDelXPubKeys :: XPubSpec -> RedisReply Integer-redisDelXPubKeys xpub = do- ebals <- redisGetXPubBalances xpub- case ebals of- Right bals -> go (map (balanceAddress . xPubBal) bals)- Left _ -> return $ ebals >> return 0+delXPubKeys :: MonadIO m => [XPubSpec] -> CacheT m Integer+delXPubKeys xpubs = do+ is <- runRedisTx (watchRedisXPubBalances xpubs) $ \xbals -> do+ xs <- forM xbals $ uncurry redisDelXPubKeys+ return $ sequence xs+ return $ sum is++watchRedisXPubBalances ::+ [XPubSpec] -> Redis (Either Reply [(XPubSpec, [XPubBal])])+watchRedisXPubBalances [] = return (pure [])+watchRedisXPubBalances xpubs = do+ watch $ map (\xpub -> balancesPfx <> encode xpub) xpubs+ bals' <- mapM redisGetXPubBalances xpubs+ return $ do+ bals <- sequence bals'+ return $ zip xpubs bals++redisDelXPubKeys ::+ (Monad f, RedisCtx m f) => XPubSpec -> [XPubBal] -> m (f Integer)+redisDelXPubKeys xpub bals = go (map (balanceAddress . xPubBal) bals) where go addrs = do addrcount <-@@ -856,27 +920,33 @@ bal' <- balcount return $ addrs' + txset' + utxo' + bal' -redisAddXPubTxs :: XPubSpec -> [BlockTx] -> RedisReply Integer-redisAddXPubTxs _ [] = return (Right 0)+redisAddXPubTxs ::+ (Applicative f, RedisCtx m f) => XPubSpec -> [BlockTx] -> m (f Integer)+redisAddXPubTxs _ [] = return (pure 0) redisAddXPubTxs xpub btxs = zadd (txSetPfx <> encode xpub) $ map (\t -> (blockRefScore (blockTxBlock t), encode (blockTxHash t))) btxs -redisRemXPubTxs :: XPubSpec -> [TxHash] -> RedisReply Integer+redisRemXPubTxs :: RedisCtx m f => XPubSpec -> [TxHash] -> m (f Integer) redisRemXPubTxs xpub txhs = zrem (txSetPfx <> encode xpub) (map encode txhs) -redisAddXPubUnspents :: XPubSpec -> [(OutPoint, BlockRef)] -> RedisReply Integer-redisAddXPubUnspents _ [] = return (Right 0)+redisAddXPubUnspents ::+ (Applicative f, RedisCtx m f)+ => XPubSpec+ -> [(OutPoint, BlockRef)]+ -> m (f Integer)+redisAddXPubUnspents _ [] = return (pure 0) redisAddXPubUnspents xpub utxo = zadd (utxoPfx <> encode xpub) $ map (\(p, r) -> (blockRefScore r, encode p)) utxo redisRemXPubUnspents ::- XPubSpec -> [OutPoint] -> RedisReply Integer-redisRemXPubUnspents _ [] = return (Right 0)+ (Applicative f, RedisCtx m f) => XPubSpec -> [OutPoint] -> m (f Integer)+redisRemXPubUnspents _ [] = return (pure 0) redisRemXPubUnspents xpub ops = zrem (utxoPfx <> encode xpub) (map encode ops) -redisAddXPubBalances :: XPubSpec -> [XPubBal] -> RedisReply ()+redisAddXPubBalances ::+ (Monad f, RedisCtx m f) => XPubSpec -> [XPubBal] -> m (f ()) redisAddXPubBalances _ [] = return (pure ()) redisAddXPubBalances xpub bals = do xs <- mapM (uncurry (Redis.hset (balancesPfx <> encode xpub))) entries@@ -890,11 +960,12 @@ where entries = map (\b -> (encode (xPubBalPath b), encode (xPubBal b))) bals -redisSetHead :: BlockHash -> RedisReply Redis.Status+redisSetHead :: RedisCtx m f => BlockHash -> m (f Redis.Status) redisSetHead bh = Redis.set bestBlockKey (encode bh) -redisGetAddrsInfo :: [Address] -> RedisReply [Maybe AddressXPub]-redisGetAddrsInfo [] = return (Right [])+redisGetAddrsInfo ::+ (Monad f, RedisCtx m f) => [Address] -> m (f [Maybe AddressXPub])+redisGetAddrsInfo [] = return (pure []) redisGetAddrsInfo as = do is <- mapM (\a -> Redis.get (addrPfx <> encode a)) as return $ do@@ -957,12 +1028,12 @@ f (Left _) _ = Nothing in catMaybes (zipWith f as ps) -redisGetHead :: RedisReply (Maybe BlockHash)+redisGetHead :: (Functor f, RedisCtx m f) => m (f (Maybe BlockHash)) redisGetHead = do x <- Redis.get bestBlockKey return $ (eitherToMaybe . decode =<<) <$> x -redisGetMempool :: RedisReply [BlockTx]+redisGetMempool :: (Applicative f, RedisCtx m f) => m (f [BlockTx]) redisGetMempool = do xs <- getFromSortedSet mempoolSetKey Nothing 0 Nothing return $ do
src/Haskoin/Store/Common.hs view
@@ -1,1424 +1,1269 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-module Haskoin.Store.Common- ( BlockStoreMessage(..)- , DeriveType(..)- , Limit- , Offset- , BlockStore- , UnixTime- , getUnixTime- , putUnixTime- , BlockPos- , XPubSpec(..)- , StoreRead(..)- , StoreWrite(..)- , JsonSerial(..)- , BinSerial(..)- , BlockRef(..)- , BlockTx(..)- , confirmed- , Balance(..)- , BlockData(..)- , StoreInput(..)- , isCoinbase- , Spender(..)- , StoreOutput(..)- , Prev(..)- , TxData(..)- , Unspent(..)- , Transaction(..)- , transactionData- , fromTransaction- , toTransaction- , TxAfterHeight(..)- , TxId(..)- , PeerInformation(..)- , XPubBal(..)- , xPubBalsTxs- , XPubUnspent(..)- , xPubBalsUnspents- , XPubSummary(..)- , HealthCheck(..)- , Event(..)- , StoreEvent(..)- , PubExcept(..)- , zeroBalance- , nullBalance- , getTransaction- , blockAtOrBefore- , applyOffset- , applyLimit- , applyOffsetLimit- , applyOffsetC- , applyLimitC- , applyOffsetLimitC- , sortTxs- ) where--import Conduit (ConduitT, dropC, mapC, takeC)-import Control.Applicative ((<|>))-import Control.DeepSeq (NFData)-import Control.Exception (Exception)-import Control.Monad (guard, mzero)-import Control.Monad.Trans (lift)-import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)-import Data.Aeson (Encoding, ToJSON (..), Value (..),- object, pairs, (.=))-import qualified Data.Aeson as A-import qualified Data.Aeson.Encoding as A-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import Data.ByteString.Short (ShortByteString)-import qualified Data.ByteString.Short as B.Short-import Data.Function (on)-import Data.Hashable (Hashable (..))-import qualified Data.IntMap as I-import Data.IntMap.Strict (IntMap)-import Data.List (nub, partition, sortBy)-import Data.Maybe (catMaybes, isJust, listToMaybe,- mapMaybe)-import Data.Serialize (Get, Put, Putter, Serialize (..),- getListOf, getShortByteString,- getWord32be, getWord64be, getWord8,- putListOf, putShortByteString,- putWord32be, putWord64be, putWord8)-import qualified Data.Serialize as S-import Data.String.Conversions (cs)-import qualified Data.Text.Encoding as T-import Data.Word (Word32, Word64)-import GHC.Generics (Generic)-import Haskoin (Address, Block, BlockHash,- BlockHeader (..), BlockHeight,- BlockNode, BlockWork, HostAddress,- KeyIndex, Network (..),- NetworkAddress (..), OutPoint (..),- PubKeyI (..), RejectCode (..),- Tx (..), TxHash (..), TxIn (..),- TxOut (..), WitnessStack,- XPubKey (..), addrToJSON,- addrToString, deriveAddr,- deriveCompatWitnessAddr,- deriveWitnessAddr, eitherToMaybe,- encodeHex, headerHash,- hostToSockAddr, pubSubKey,- scriptToAddressBS, stringToAddr,- txHash, wrapPubKey)-import Haskoin.Node (Peer)-import Network.Socket (SockAddr)-import NQE (Listen, Mailbox)-import qualified Paths_haskoin_store as P--data DeriveType- = DeriveNormal- | DeriveP2SH- | DeriveP2WPKH- deriving (Show, Eq, Generic, NFData, Serialize)---- | Messages for block store actor.-data BlockStoreMessage- = BlockNewBest !BlockNode- -- ^ new block header in chain- | BlockPeerConnect !Peer !SockAddr- -- ^ new peer connected- | BlockPeerDisconnect !Peer !SockAddr- -- ^ peer disconnected- | BlockReceived !Peer !Block- -- ^ new block received from a peer- | BlockNotFound !Peer ![BlockHash]- -- ^ block not found- | BlockTxReceived !Peer !Tx- -- ^ transaction received from peer- | BlockTxAvailable !Peer ![TxHash]- -- ^ peer has transactions available- | BlockPing !(Listen ())- -- ^ internal housekeeping ping---- | Mailbox for block store.-type BlockStore = Mailbox BlockStoreMessage--data XPubSpec =- XPubSpec- { xPubSpecKey :: !XPubKey- , xPubDeriveType :: !DeriveType- } deriving (Show, Eq, Generic, NFData)--instance Hashable XPubSpec where- hashWithSalt i XPubSpec {xPubSpecKey = XPubKey {xPubKey = pubkey}} =- hashWithSalt i pubkey--instance Serialize XPubSpec where- put XPubSpec {xPubSpecKey = k, xPubDeriveType = t} = do- put (xPubDepth k)- put (xPubParent k)- put (xPubIndex k)- put (xPubChain k)- put (wrapPubKey True (xPubKey k))- put t- get = do- d <- get- p <- get- i <- get- c <- get- k <- get- t <- get- let x =- XPubKey- { xPubDepth = d- , xPubParent = p- , xPubIndex = i- , xPubChain = c- , xPubKey = pubKeyPoint k- }- return XPubSpec {xPubSpecKey = x, xPubDeriveType = t}--type DeriveAddr = XPubKey -> KeyIndex -> Address--type UnixTime = Word64-type BlockPos = Word32--type Offset = Word32-type Limit = Word32--class Monad m =>- StoreRead m- where- getBestBlock :: m (Maybe BlockHash)- getBlocksAtHeight :: BlockHeight -> m [BlockHash]- getBlock :: BlockHash -> m (Maybe BlockData)- getTxData :: TxHash -> m (Maybe TxData)- getOrphanTx :: TxHash -> m (Maybe (UnixTime, Tx))- getOrphans :: m [(UnixTime, Tx)]- getSpenders :: TxHash -> m (IntMap Spender)- getSpender :: OutPoint -> m (Maybe Spender)- getBalance :: Address -> m Balance- getBalance a = head <$> getBalances [a]- getBalances :: [Address] -> m [Balance]- getBalances as = mapM getBalance as- getAddressesTxs :: [Address] -> Maybe BlockRef -> Maybe Limit -> m [BlockTx]- getAddressTxs :: Address -> Maybe BlockRef -> Maybe Limit -> m [BlockTx]- getAddressTxs a = getAddressesTxs [a]- getUnspent :: OutPoint -> m (Maybe Unspent)- getAddressUnspents ::- Address -> Maybe BlockRef -> Maybe Limit -> m [Unspent]- getAddressUnspents a = getAddressesUnspents [a]- getAddressesUnspents ::- [Address] -> Maybe BlockRef -> Maybe Limit -> m [Unspent]- getMempool :: m [BlockTx]- xPubBals :: XPubSpec -> m [XPubBal]- xPubBals xpub = do- gap <- getMaxGap- ext <-- derive_until_gap- gap- 0- (deriveAddresses- (deriveFunction (xPubDeriveType xpub))- (pubSubKey (xPubSpecKey xpub) 0)- 0)- chg <-- derive_until_gap- gap- 1- (deriveAddresses- (deriveFunction (xPubDeriveType xpub))- (pubSubKey (xPubSpecKey xpub) 1)- 0)- return (ext ++ chg)- where- xbalance m b n = XPubBal {xPubBalPath = [m, n], xPubBal = b}- derive_until_gap _ _ [] = return []- derive_until_gap gap m as = do- let (as1, as2) = splitAt (fromIntegral gap) as- bs <- getBalances (map snd as1)- let xbs = zipWith (xbalance m) bs (map fst as1)- if all nullBalance bs- then return xbs- else (xbs <>) <$> derive_until_gap gap m as2- xPubSummary :: XPubSpec -> m XPubSummary- xPubSummary xpub = do- bs <- filter (not . nullBalance . xPubBal) <$> xPubBals xpub- let ex = foldl max 0 [i | XPubBal {xPubBalPath = [0, i]} <- bs]- ch = foldl max 0 [i | XPubBal {xPubBalPath = [1, i]} <- bs]- uc =- sum- [ c- | XPubBal {xPubBal = Balance {balanceUnspentCount = c}} <-- bs- ]- xt = [b | b@XPubBal {xPubBalPath = [0, _]} <- bs]- rx =- sum- [ r- | XPubBal {xPubBal = Balance {balanceTotalReceived = r}} <-- xt- ]- return- XPubSummary- { xPubSummaryConfirmed = sum (map (balanceAmount . xPubBal) bs)- , xPubSummaryZero = sum (map (balanceZero . xPubBal) bs)- , xPubSummaryReceived = rx- , xPubUnspentCount = uc- , xPubChangeIndex = ch- , xPubExternalIndex = ex- }- xPubUnspents ::- XPubSpec- -> Maybe BlockRef- -> Offset- -> Maybe Limit- -> m [XPubUnspent]- xPubUnspents xpub start offset limit = do- xs <- filter positive <$> xPubBals xpub- applyOffsetLimit offset limit <$> go xs- where- positive XPubBal {xPubBal = Balance {balanceUnspentCount = c}} = c > 0- go [] = return []- go (XPubBal {xPubBalPath = p, xPubBal = Balance {balanceAddress = a}}:xs) = do- uns <- getAddressUnspents a start limit- let xuns =- map- (\t ->- XPubUnspent {xPubUnspentPath = p, xPubUnspent = t})- uns- (xuns <>) <$> go xs- xPubTxs ::- XPubSpec -> Maybe BlockRef -> Offset -> Maybe Limit -> m [BlockTx]- xPubTxs xpub start offset limit = do- bs <- xPubBals xpub- let as = map (balanceAddress . xPubBal) bs- ts <- concat <$> mapM (\a -> getAddressTxs a start limit) as- let ts' = nub $ sortBy (flip compare `on` blockTxBlock) ts- return $ applyOffsetLimit offset limit ts'- getMaxGap :: m Word32- getMaxGap = return 32--class StoreWrite m where- setBest :: BlockHash -> m ()- insertBlock :: BlockData -> m ()- setBlocksAtHeight :: [BlockHash] -> BlockHeight -> m ()- insertTx :: TxData -> m ()- insertSpender :: OutPoint -> Spender -> m ()- deleteSpender :: OutPoint -> m ()- insertAddrTx :: Address -> BlockTx -> m ()- deleteAddrTx :: Address -> BlockTx -> m ()- insertAddrUnspent :: Address -> Unspent -> m ()- deleteAddrUnspent :: Address -> Unspent -> m ()- setMempool :: [BlockTx] -> m ()- insertOrphanTx :: Tx -> UnixTime -> m ()- deleteOrphanTx :: TxHash -> m ()- setBalance :: Balance -> m ()- insertUnspent :: Unspent -> m ()- deleteUnspent :: OutPoint -> m ()--deriveAddresses :: DeriveAddr -> XPubKey -> Word32 -> [(Word32, Address)]-deriveAddresses derive xpub start = map (\i -> (i, derive xpub i)) [start ..]--deriveFunction :: DeriveType -> DeriveAddr-deriveFunction DeriveNormal i = fst . deriveAddr i-deriveFunction DeriveP2SH i = fst . deriveCompatWitnessAddr i-deriveFunction DeriveP2WPKH i = fst . deriveWitnessAddr i--xPubBalsUnspents ::- StoreRead m- => [XPubBal]- -> Maybe BlockRef- -> Offset- -> Maybe Limit- -> m [XPubUnspent]-xPubBalsUnspents bals start offset limit = do- let xs = filter positive bals- applyOffsetLimit offset limit <$> go xs- where- positive XPubBal {xPubBal = Balance {balanceUnspentCount = c}} = c > 0- go [] = return []- go (XPubBal {xPubBalPath = p, xPubBal = Balance {balanceAddress = a}}:xs) = do- uns <- getAddressUnspents a start limit- let xuns =- map- (\t ->- XPubUnspent {xPubUnspentPath = p, xPubUnspent = t})- uns- (xuns <>) <$> go xs--xPubBalsTxs ::- StoreRead m- => [XPubBal]- -> Maybe BlockRef- -> Offset- -> Maybe Limit- -> m [BlockTx]-xPubBalsTxs bals start offset limit = do- let as = map balanceAddress . filter (not . nullBalance) $ map xPubBal bals- ts <- concat <$> mapM (\a -> getAddressTxs a start limit) as- let ts' = nub $ sortBy (flip compare `on` blockTxBlock) ts- return $ applyOffsetLimit offset limit ts'--getTransaction ::- (Monad m, StoreRead m) => TxHash -> m (Maybe Transaction)-getTransaction h = runMaybeT $ do- d <- MaybeT $ getTxData h- sm <- lift $ getSpenders h- return $ toTransaction d sm--blockAtOrBefore :: (Monad m, StoreRead m) => UnixTime -> m (Maybe BlockData)-blockAtOrBefore q = runMaybeT $ do- a <- g 0- b <- MaybeT getBestBlock >>= MaybeT . getBlock- f a b- where- f a b- | t b <= q = return b- | t a > q = mzero- | h b - h a == 1 = return a- | otherwise = do- let x = h a + (h b - h a) `div` 2- m <- g x- if t m > q then f a m else f m b- g x = MaybeT (listToMaybe <$> getBlocksAtHeight x) >>= MaybeT . getBlock- h = blockDataHeight- t = fromIntegral . blockTimestamp . blockDataHeader---- | Serialize such that ordering is inverted.-putUnixTime :: Word64 -> Put-putUnixTime w = putWord64be $ maxBound - w--getUnixTime :: Get Word64-getUnixTime = (maxBound -) <$> getWord64be--class JsonSerial a where- jsonSerial :: Network -> a -> Encoding- jsonValue :: Network -> a -> Value--instance JsonSerial a => JsonSerial [a] where- jsonSerial net = A.list (jsonSerial net)- jsonValue net = toJSON . (jsonValue net)--instance JsonSerial TxHash where- jsonSerial _ = toEncoding- jsonValue _ = toJSON--instance BinSerial TxHash where- binSerial _ = put- binDeserial _ = get--instance BinSerial Address where- binSerial net a =- case addrToString net a of- Nothing -> put B.empty- Just x -> put $ T.encodeUtf8 x-- binDeserial net = do- bs <- get- guard (not (B.null bs))- t <- case T.decodeUtf8' bs of- Left _ -> mzero- Right v -> return v- case stringToAddr net t of- Nothing -> mzero- Just x -> return x--class BinSerial a where- binSerial :: Network -> Putter a- binDeserial :: Network -> Get a--instance BinSerial a => BinSerial [a] where- binSerial net = putListOf (binSerial net)- binDeserial net = getListOf (binDeserial net)---- | Reference to a block where a transaction is stored.-data BlockRef- = BlockRef- { blockRefHeight :: !BlockHeight- -- ^ block height in the chain- , blockRefPos :: !Word32- -- ^ position of transaction within the block- }- | MemRef- { memRefTime :: !UnixTime- }- deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData)---- | Serialized entities will sort in reverse order.-instance Serialize BlockRef where- put MemRef {memRefTime = t} = do- putWord8 0x00- putUnixTime t- put BlockRef {blockRefHeight = h, blockRefPos = p} = do- putWord8 0x01- putWord32be (maxBound - h)- putWord32be (maxBound - p)- get = getmemref <|> getblockref- where- getmemref = do- guard . (== 0x00) =<< getWord8- MemRef <$> getUnixTime- getblockref = do- guard . (== 0x01) =<< getWord8- h <- (maxBound -) <$> getWord32be- p <- (maxBound -) <$> getWord32be- return BlockRef {blockRefHeight = h, blockRefPos = p}--instance BinSerial BlockRef where- binSerial _ BlockRef {blockRefHeight = h, blockRefPos = p} = do- putWord8 0x00- putWord32be h- putWord32be p- binSerial _ MemRef {memRefTime = t} = do- putWord8 0x01- putWord64be t-- binDeserial _ = getWord8 >>=- \case- 0x00 -> BlockRef <$> getWord32be <*> getWord32be- 0x01 -> MemRef <$> getUnixTime- _ -> fail "Expected fst byte to be 0x00 or 0x01"---- | JSON serialization for 'BlockRef'.-blockRefPairs :: A.KeyValue kv => BlockRef -> [kv]-blockRefPairs BlockRef {blockRefHeight = h, blockRefPos = p} =- ["height" .= h, "position" .= p]-blockRefPairs MemRef {memRefTime = t} = ["mempool" .= t]--confirmed :: BlockRef -> Bool-confirmed BlockRef {} = True-confirmed MemRef {} = False--instance ToJSON BlockRef where- toJSON = object . blockRefPairs- toEncoding = pairs . mconcat . blockRefPairs---- | Transaction in relation to an address.-data BlockTx = BlockTx- { blockTxBlock :: !BlockRef- -- ^ block information- , blockTxHash :: !TxHash- -- ^ transaction hash- } deriving (Show, Eq, Ord, Generic, Serialize, Hashable, NFData)---- | JSON serialization for 'AddressTx'.-blockTxPairs :: A.KeyValue kv => BlockTx -> [kv]-blockTxPairs btx =- [ "txid" .= blockTxHash btx- , "block" .= blockTxBlock btx- ]--instance ToJSON BlockTx where- toJSON = object . blockTxPairs- toEncoding = pairs . mconcat . blockTxPairs--instance JsonSerial BlockTx where- jsonSerial _ = toEncoding- jsonValue _ = toJSON--instance BinSerial BlockTx where- binSerial net BlockTx { blockTxBlock = b, blockTxHash = h } = do- binSerial net b- binSerial net h-- binDeserial net = BlockTx <$> binDeserial net <*> binDeserial net---- | Address balance information.-data Balance = Balance- { balanceAddress :: !Address- -- ^ address balance- , balanceAmount :: !Word64- -- ^ confirmed balance- , balanceZero :: !Word64- -- ^ unconfirmed balance- , balanceUnspentCount :: !Word64- -- ^ number of unspent outputs- , balanceTxCount :: !Word64- -- ^ number of transactions- , balanceTotalReceived :: !Word64- -- ^ total amount from all outputs in this address- } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData)--zeroBalance :: Address -> Balance-zeroBalance a =- Balance- { balanceAddress = a- , balanceAmount = 0- , balanceUnspentCount = 0- , balanceZero = 0- , balanceTxCount = 0- , balanceTotalReceived = 0- }--nullBalance :: Balance -> Bool-nullBalance Balance { balanceAmount = 0- , balanceUnspentCount = 0- , balanceZero = 0- , balanceTxCount = 0- , balanceTotalReceived = 0- } = True-nullBalance _ = False---- | JSON serialization for 'Balance'.-balancePairs :: A.KeyValue kv => Network -> Balance -> [kv]-balancePairs net ab =- [ "address" .= addrToJSON net (balanceAddress ab)- , "confirmed" .= balanceAmount ab- , "unconfirmed" .= balanceZero ab- , "utxo" .= balanceUnspentCount ab- , "txs" .= balanceTxCount ab- , "received" .= balanceTotalReceived ab- ]--balanceToJSON :: Network -> Balance -> Value-balanceToJSON net = object . balancePairs net--balanceToEncoding :: Network -> Balance -> Encoding-balanceToEncoding net = pairs . mconcat . balancePairs net--instance JsonSerial Balance where- jsonSerial = balanceToEncoding- jsonValue = balanceToJSON--instance BinSerial Balance where- binSerial net Balance { balanceAddress = a- , balanceAmount = v- , balanceZero = z- , balanceUnspentCount = u- , balanceTxCount = c- , balanceTotalReceived = t- } = do- binSerial net a- putWord64be v- putWord64be z- putWord64be u- putWord64be c- putWord64be t-- binDeserial net =- Balance <$> binDeserial net- <*> getWord64be- <*> getWord64be- <*> getWord64be- <*> getWord64be- <*> getWord64be----- | Unspent output.-data Unspent = Unspent- { unspentBlock :: !BlockRef- -- ^ block information for output- , unspentPoint :: !OutPoint- -- ^ txid and index where output located- , unspentAmount :: !Word64- -- ^ value of output in satoshi- , unspentScript :: !ShortByteString- -- ^ pubkey (output) script- } deriving (Show, Eq, Ord, Generic, Hashable, NFData)--instance Serialize Unspent where- put u = do- put $ unspentBlock u- put $ unspentPoint u- put $ unspentAmount u- put $ B.Short.length (unspentScript u)- putShortByteString $ unspentScript u- get =- Unspent <$> get <*> get <*> get <*> (getShortByteString =<< get)--unspentPairs :: A.KeyValue kv => Network -> Unspent -> [kv]-unspentPairs net u =- [ "address" .=- eitherToMaybe- (addrToJSON net <$>- scriptToAddressBS (B.Short.fromShort (unspentScript u)))- , "block" .= unspentBlock u- , "txid" .= outPointHash (unspentPoint u)- , "index" .= outPointIndex (unspentPoint u)- , "pkscript" .= String (encodeHex (B.Short.fromShort (unspentScript u)))- , "value" .= unspentAmount u- ]--unspentToJSON :: Network -> Unspent -> Value-unspentToJSON net = object . unspentPairs net--unspentToEncoding :: Network -> Unspent -> Encoding-unspentToEncoding net = pairs . mconcat . unspentPairs net--instance JsonSerial Unspent where- jsonSerial = unspentToEncoding- jsonValue = unspentToJSON--instance BinSerial Unspent where- binSerial net Unspent { unspentBlock = b- , unspentPoint = p- , unspentAmount = v- , unspentScript = s- } = do- binSerial net b- put p- putWord64be v- put s-- binDeserial net =- Unspent- <$> binDeserial net- <*> get- <*> getWord64be- <*> get---- | Database value for a block entry.-data BlockData = BlockData- { blockDataHeight :: !BlockHeight- -- ^ height of the block in the chain- , blockDataMainChain :: !Bool- -- ^ is this block in the main chain?- , blockDataWork :: !BlockWork- -- ^ accumulated work in that block- , blockDataHeader :: !BlockHeader- -- ^ block header- , blockDataSize :: !Word32- -- ^ size of the block including witnesses- , blockDataWeight :: !Word32- -- ^ weight of this block (for segwit networks)- , blockDataTxs :: ![TxHash]- -- ^ block transactions- , blockDataOutputs :: !Word64- -- ^ sum of all transaction outputs- , blockDataFees :: !Word64- -- ^ sum of all transaction fees- , blockDataSubsidy :: !Word64- -- ^ block subsidy- } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData)---- | JSON serialization for 'BlockData'.-blockDataPairs :: A.KeyValue kv => Network -> BlockData -> [kv]-blockDataPairs net bv =- [ "hash" .= headerHash (blockDataHeader bv)- , "height" .= blockDataHeight bv- , "mainchain" .= blockDataMainChain bv- , "previous" .= prevBlock (blockDataHeader bv)- , "time" .= blockTimestamp (blockDataHeader bv)- , "version" .= blockVersion (blockDataHeader bv)- , "bits" .= blockBits (blockDataHeader bv)- , "nonce" .= bhNonce (blockDataHeader bv)- , "size" .= blockDataSize bv- , "tx" .= blockDataTxs bv- , "merkle" .= TxHash (merkleRoot (blockDataHeader bv))- , "subsidy" .= blockDataSubsidy bv- , "fees" .= blockDataFees bv- , "outputs" .= blockDataOutputs bv- ] ++ ["weight" .= blockDataWeight bv | getSegWit net]--blockDataToJSON :: Network -> BlockData -> Value-blockDataToJSON net = object . blockDataPairs net--blockDataToEncoding :: Network -> BlockData -> Encoding-blockDataToEncoding net = pairs . mconcat . blockDataPairs net--instance JsonSerial BlockData where- jsonSerial = blockDataToEncoding- jsonValue = blockDataToJSON--instance BinSerial BlockData where- binSerial _ BlockData { blockDataHeight = e- , blockDataMainChain = m- , blockDataWork = w- , blockDataHeader = h- , blockDataSize = z- , blockDataWeight = g- , blockDataTxs = t- , blockDataOutputs = o- , blockDataFees = f- , blockDataSubsidy = y- } = do- put m- putWord32be e- put h- put w- putWord32be z- putWord32be g- putWord64be o- putWord64be f- putWord64be y- put t-- binDeserial _ = do- m <- get- e <- getWord32be- h <- get- w <- get- z <- getWord32be- g <- getWord32be- o <- getWord64be- f <- getWord64be- y <- getWord64be- t <- get- return $ BlockData e m w h z g t o f y---- | Input information.-data StoreInput- = StoreCoinbase { inputPoint :: !OutPoint- -- ^ output being spent (should be null)- , inputSequence :: !Word32- -- ^ sequence- , inputSigScript :: !ByteString- -- ^ input script data (not valid script)- , inputWitness :: !(Maybe WitnessStack)- -- ^ witness data for this input (only segwit)- }- -- ^ coinbase details- | StoreInput { inputPoint :: !OutPoint- -- ^ output being spent- , inputSequence :: !Word32- -- ^ sequence- , inputSigScript :: !ByteString- -- ^ signature (input) script- , inputPkScript :: !ByteString- -- ^ pubkey (output) script from previous tx- , inputAmount :: !Word64- -- ^ amount in satoshi being spent spent- , inputWitness :: !(Maybe WitnessStack)- -- ^ witness data for this input (only segwit)- }- -- ^ input details- deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData)--isCoinbase :: StoreInput -> Bool-isCoinbase StoreCoinbase {} = True-isCoinbase StoreInput {} = False--inputPairs :: A.KeyValue kv => Network -> StoreInput -> [kv]-inputPairs net StoreInput { inputPoint = OutPoint oph opi- , inputSequence = sq- , inputSigScript = ss- , inputPkScript = ps- , inputAmount = val- , inputWitness = wit- } =- [ "coinbase" .= False- , "txid" .= oph- , "output" .= opi- , "sigscript" .= String (encodeHex ss)- , "sequence" .= sq- , "pkscript" .= String (encodeHex ps)- , "value" .= val- , "address" .= eitherToMaybe (addrToJSON net <$> scriptToAddressBS ps)- ] ++- ["witness" .= fmap (map encodeHex) wit | getSegWit net]--inputPairs net StoreCoinbase { inputPoint = OutPoint oph opi- , inputSequence = sq- , inputSigScript = ss- , inputWitness = wit- } =- [ "coinbase" .= True- , "txid" .= oph- , "output" .= opi- , "sigscript" .= String (encodeHex ss)- , "sequence" .= sq- , "pkscript" .= Null- , "value" .= Null- , "address" .= Null- ] ++- ["witness" .= fmap (map encodeHex) wit | getSegWit net]---- | Information about input spending output.-data Spender = Spender- { spenderHash :: !TxHash- -- ^ input transaction hash- , spenderIndex :: !Word32- -- ^ input position in transaction- } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData)---- | JSON serialization for 'Spender'.-spenderPairs :: A.KeyValue kv => Spender -> [kv]-spenderPairs n =- ["txid" .= spenderHash n, "input" .= spenderIndex n]--instance ToJSON Spender where- toJSON = object . spenderPairs- toEncoding = pairs . mconcat . spenderPairs---- | Output information.-data StoreOutput = StoreOutput- { outputAmount :: !Word64- -- ^ amount in satoshi- , outputScript :: !ByteString- -- ^ pubkey (output) script- , outputSpender :: !(Maybe Spender)- -- ^ input spending this transaction- } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData)--outputPairs :: A.KeyValue kv => Network -> StoreOutput -> [kv]-outputPairs net d =- [ "address" .=- eitherToMaybe (addrToJSON net <$> scriptToAddressBS (outputScript d))- , "pkscript" .= String (encodeHex (outputScript d))- , "value" .= outputAmount d- , "spent" .= isJust (outputSpender d)- ] ++- ["spender" .= outputSpender d | isJust (outputSpender d)]--data Prev = Prev- { prevScript :: !ByteString- , prevAmount :: !Word64- } deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData)--toInput :: TxIn -> Maybe Prev -> Maybe WitnessStack -> StoreInput-toInput i Nothing w =- StoreCoinbase- { inputPoint = prevOutput i- , inputSequence = txInSequence i- , inputSigScript = scriptInput i- , inputWitness = w- }-toInput i (Just p) w =- StoreInput- { inputPoint = prevOutput i- , inputSequence = txInSequence i- , inputSigScript = scriptInput i- , inputPkScript = prevScript p- , inputAmount = prevAmount p- , inputWitness = w- }--toOutput :: TxOut -> Maybe Spender -> StoreOutput-toOutput o s =- StoreOutput- { outputAmount = outValue o- , outputScript = scriptOutput o- , outputSpender = s- }--data TxData = TxData- { txDataBlock :: !BlockRef- , txData :: !Tx- , txDataPrevs :: !(IntMap Prev)- , txDataDeleted :: !Bool- , txDataRBF :: !Bool- , txDataTime :: !Word64- } deriving (Show, Eq, Ord, Generic, Serialize, NFData)--instance BinSerial TxData where- binSerial _ TxData- { txDataBlock = br- , txData = tx- , txDataPrevs = dp- , txDataDeleted = dd- , txDataRBF = dr- , txDataTime = t- } = do- put br- put tx- put dp- put dd- put dr- putWord64be t-- binDeserial _ = do br <- get- tx <- get- dp <- get- dd <- get- dr <- get- TxData br tx dp dd dr <$> getWord64be--instance Serialize a => BinSerial (IntMap a) where- binSerial _ = put- binDeserial _ = get--toTransaction :: TxData -> IntMap Spender -> Transaction-toTransaction t sm =- Transaction- { transactionBlock = txDataBlock t- , transactionVersion = txVersion (txData t)- , transactionLockTime = txLockTime (txData t)- , transactionInputs = ins- , transactionOutputs = outs- , transactionDeleted = txDataDeleted t- , transactionRBF = txDataRBF t- , transactionTime = txDataTime t- }- where- ws =- take (length (txIn (txData t))) $- map Just (txWitness (txData t)) <> repeat Nothing- f n i = toInput i (I.lookup n (txDataPrevs t)) (ws !! n)- ins = zipWith f [0 ..] (txIn (txData t))- g n o = toOutput o (I.lookup n sm)- outs = zipWith g [0 ..] (txOut (txData t))--fromTransaction :: Transaction -> (TxData, IntMap Spender)-fromTransaction t = (d, sm)- where- d =- TxData- { txDataBlock = transactionBlock t- , txData = transactionData t- , txDataPrevs = ps- , txDataDeleted = transactionDeleted t- , txDataRBF = transactionRBF t- , txDataTime = transactionTime t- }- f _ StoreCoinbase {} = Nothing- f n StoreInput {inputPkScript = s, inputAmount = v} =- Just (n, Prev {prevScript = s, prevAmount = v})- ps = I.fromList . catMaybes $ zipWith f [0 ..] (transactionInputs t)- g _ StoreOutput {outputSpender = Nothing} = Nothing- g n StoreOutput {outputSpender = Just s} = Just (n, s)- sm = I.fromList . catMaybes $ zipWith g [0 ..] (transactionOutputs t)---- | Detailed transaction information.-data Transaction = Transaction- { transactionBlock :: !BlockRef- -- ^ block information for this transaction- , transactionVersion :: !Word32- -- ^ transaction version- , transactionLockTime :: !Word32- -- ^ lock time- , transactionInputs :: ![StoreInput]- -- ^ transaction inputs- , transactionOutputs :: ![StoreOutput]- -- ^ transaction outputs- , transactionDeleted :: !Bool- -- ^ this transaction has been deleted and is no longer valid- , transactionRBF :: !Bool- -- ^ this transaction can be replaced in the mempool- , transactionTime :: !Word64- -- ^ time the transaction was first seen or time of block- } deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData)--transactionData :: Transaction -> Tx-transactionData t =- Tx- { txVersion = transactionVersion t- , txIn = map i (transactionInputs t)- , txOut = map o (transactionOutputs t)- , txWitness = mapMaybe inputWitness (transactionInputs t)- , txLockTime = transactionLockTime t- }- where- i StoreCoinbase {inputPoint = p, inputSequence = q, inputSigScript = s} =- TxIn {prevOutput = p, scriptInput = s, txInSequence = q}- i StoreInput {inputPoint = p, inputSequence = q, inputSigScript = s} =- TxIn {prevOutput = p, scriptInput = s, txInSequence = q}- o StoreOutput {outputAmount = v, outputScript = s} =- TxOut {outValue = v, scriptOutput = s}---- | JSON serialization for 'Transaction'.-transactionPairs :: A.KeyValue kv => Network -> Transaction -> [kv]-transactionPairs net dtx =- [ "txid" .= txHash (transactionData dtx)- , "size" .= B.length (S.encode (transactionData dtx))- , "version" .= transactionVersion dtx- , "locktime" .= transactionLockTime dtx- , "fee" .=- if all isCoinbase (transactionInputs dtx)- then 0- else sum (map inputAmount (transactionInputs dtx)) -- sum (map outputAmount (transactionOutputs dtx))- , "inputs" .= map (object . inputPairs net) (transactionInputs dtx)- , "outputs" .= map (object . outputPairs net) (transactionOutputs dtx)- , "block" .= transactionBlock dtx- , "deleted" .= transactionDeleted dtx- , "time" .= transactionTime dtx- ] ++- ["rbf" .= transactionRBF dtx | getReplaceByFee net] ++- ["weight" .= w | getSegWit net]- where- w = let b = B.length $ S.encode (transactionData dtx) {txWitness = []}- x = B.length $ S.encode (transactionData dtx)- in b * 3 + x--transactionToJSON :: Network -> Transaction -> Value-transactionToJSON net = object . transactionPairs net--transactionToEncoding :: Network -> Transaction -> Encoding-transactionToEncoding net = pairs . mconcat . transactionPairs net--instance JsonSerial Transaction where- jsonSerial = transactionToEncoding- jsonValue = transactionToJSON--instance BinSerial Transaction where- binSerial net tx = do- let (txd, sp) = fromTransaction tx- binSerial net txd- binSerial net sp-- binDeserial net = do- txd <- binDeserial net- sp <- binDeserial net- return $ toTransaction txd sp--instance JsonSerial Tx where- jsonSerial _ = toEncoding- jsonValue _ = toJSON--instance BinSerial Tx where- binSerial _ = put- binDeserial _ = get--instance JsonSerial Block where- jsonSerial _ = toEncoding- jsonValue _ = toJSON--instance BinSerial Block where- binSerial _ = put- binDeserial _ = get---- | Information about a connected peer.-data PeerInformation- = PeerInformation { peerUserAgent :: !ByteString- -- ^ user agent string- , peerAddress :: !HostAddress- -- ^ network address- , peerVersion :: !Word32- -- ^ version number- , peerServices :: !Word64- -- ^ services field- , peerRelay :: !Bool- -- ^ will relay transactions- }- deriving (Show, Eq, Ord, Generic, NFData)---- | JSON serialization for 'PeerInformation'.-peerInformationPairs :: A.KeyValue kv => PeerInformation -> [kv]-peerInformationPairs p =- [ "useragent" .= String (cs (peerUserAgent p))- , "address" .= String (cs (show (hostToSockAddr (peerAddress p))))- , "version" .= peerVersion p- , "services" .= String (encodeHex (S.encode (peerServices p)))- , "relay" .= peerRelay p- ]--instance ToJSON PeerInformation where- toJSON = object . peerInformationPairs- toEncoding = pairs . mconcat . peerInformationPairs--instance JsonSerial PeerInformation where- jsonSerial _ = toEncoding- jsonValue _ = toJSON--instance BinSerial PeerInformation where- binSerial _ PeerInformation { peerUserAgent = u- , peerAddress = a- , peerVersion = v- , peerServices = s- , peerRelay = b- } = do- putWord32be v- put b- put u- put $ NetworkAddress s a-- binDeserial _ = do- v <- getWord32be- b <- get- u <- get- NetworkAddress { naServices = s, naAddress = a } <- get- return $ PeerInformation u a v s b---- | Address balances for an extended public key.-data XPubBal = XPubBal- { xPubBalPath :: ![KeyIndex]- , xPubBal :: !Balance- } deriving (Show, Ord, Eq, Generic, NFData)---- | JSON serialization for 'XPubBal'.-xPubBalPairs :: A.KeyValue kv => Network -> XPubBal -> [kv]-xPubBalPairs net XPubBal {xPubBalPath = p, xPubBal = b} =- [ "path" .= p- , "balance" .= balanceToJSON net b- ]--xPubBalToJSON :: Network -> XPubBal -> Value-xPubBalToJSON net = object . xPubBalPairs net--xPubBalToEncoding :: Network -> XPubBal -> Encoding-xPubBalToEncoding net = pairs . mconcat . xPubBalPairs net--instance JsonSerial XPubBal where- jsonSerial = xPubBalToEncoding- jsonValue = xPubBalToJSON--instance BinSerial XPubBal where- binSerial net XPubBal {xPubBalPath = p, xPubBal = b} = do- put p- binSerial net b- binDeserial net = do- p <- get- b <- binDeserial net- return $ XPubBal p b---- | Unspent transaction for extended public key.-data XPubUnspent = XPubUnspent- { xPubUnspentPath :: ![KeyIndex]- , xPubUnspent :: !Unspent- } deriving (Show, Eq, Generic, Serialize, NFData)---- | JSON serialization for 'XPubUnspent'.-xPubUnspentPairs :: A.KeyValue kv => Network -> XPubUnspent -> [kv]-xPubUnspentPairs net XPubUnspent { xPubUnspentPath = p- , xPubUnspent = u- } =- [ "path" .= p- , "unspent" .= unspentToJSON net u- ]--xPubUnspentToJSON :: Network -> XPubUnspent -> Value-xPubUnspentToJSON net = object . xPubUnspentPairs net--xPubUnspentToEncoding :: Network -> XPubUnspent -> Encoding-xPubUnspentToEncoding net = pairs . mconcat . xPubUnspentPairs net--instance JsonSerial XPubUnspent where- jsonSerial = xPubUnspentToEncoding- jsonValue = xPubUnspentToJSON--instance BinSerial XPubUnspent where- binSerial net XPubUnspent {xPubUnspentPath = p, xPubUnspent = u} = do- put p- binSerial net u-- binDeserial net = do- p <- get- u <- binDeserial net- return $ XPubUnspent p u--data XPubSummary =- XPubSummary- { xPubSummaryConfirmed :: !Word64- , xPubSummaryZero :: !Word64- , xPubSummaryReceived :: !Word64- , xPubUnspentCount :: !Word64- , xPubExternalIndex :: !Word32- , xPubChangeIndex :: !Word32- }- deriving (Eq, Show, Generic, Serialize, NFData)--xPubSummaryPairs :: A.KeyValue kv => XPubSummary -> [kv]-xPubSummaryPairs XPubSummary { xPubSummaryConfirmed = c- , xPubSummaryZero = z- , xPubSummaryReceived = r- , xPubUnspentCount = u- , xPubExternalIndex = ext- , xPubChangeIndex = ch- } =- [ "balance" .=- object- ["confirmed" .= c, "unconfirmed" .= z, "received" .= r, "utxo" .= u]- , "indices" .= object ["change" .= ch, "external" .= ext]- ]--xPubSummaryToJSON :: XPubSummary -> Value-xPubSummaryToJSON = object . xPubSummaryPairs--xPubSummaryToEncoding :: XPubSummary -> Encoding-xPubSummaryToEncoding = pairs . mconcat . xPubSummaryPairs--instance ToJSON XPubSummary where- toJSON = xPubSummaryToJSON- toEncoding = xPubSummaryToEncoding--instance JsonSerial XPubSummary where- jsonSerial _ = xPubSummaryToEncoding- jsonValue _ = xPubSummaryToJSON--instance BinSerial XPubSummary where- binSerial _ = put- binDeserial _ = get--data HealthCheck =- HealthCheck- { healthHeaderBest :: !(Maybe BlockHash)- , healthHeaderHeight :: !(Maybe BlockHeight)- , healthBlockBest :: !(Maybe BlockHash)- , healthBlockHeight :: !(Maybe BlockHeight)- , healthPeers :: !(Maybe Int)- , healthNetwork :: !String- , healthOK :: !Bool- , healthSynced :: !Bool- , healthLastBlock :: !(Maybe Word64)- , healthLastTx :: !(Maybe Word64)- }- deriving (Show, Eq, Generic, Serialize, NFData)--healthCheckPairs :: A.KeyValue kv => HealthCheck -> [kv]-healthCheckPairs h =- [ "headers" .=- object ["hash" .= healthHeaderBest h, "height" .= healthHeaderHeight h]- , "blocks" .=- object ["hash" .= healthBlockBest h, "height" .= healthBlockHeight h]- , "peers" .= healthPeers h- , "net" .= healthNetwork h- , "ok" .= healthOK h- , "synced" .= healthSynced h- , "version" .= P.version- , "lastblock" .= healthLastBlock h- , "lasttx" .= healthLastTx h- ]--instance ToJSON HealthCheck where- toJSON = object . healthCheckPairs- toEncoding = pairs . mconcat . healthCheckPairs--instance JsonSerial HealthCheck where- jsonSerial _ = toEncoding- jsonValue _ = toJSON--instance BinSerial HealthCheck where- binSerial _ HealthCheck { healthHeaderBest = hbest- , healthHeaderHeight = hheight- , healthBlockBest = bbest- , healthBlockHeight = bheight- , healthPeers = peers- , healthNetwork = net- , healthOK = ok- , healthSynced = synced- , healthLastBlock = lbk- , healthLastTx = ltx- } = do- put hbest- put hheight- put bbest- put bheight- put peers- put net- put ok- put synced- put lbk- put ltx- binDeserial _ =- HealthCheck <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*>- get <*>- get <*>- get--data Event- = EventBlock BlockHash- | EventTx TxHash- deriving (Show, Eq, Generic)--instance ToJSON Event where- toJSON (EventTx h) = object ["type" .= String "tx", "id" .= h]- toJSON (EventBlock h) = object ["type" .= String "block", "id" .= h]--instance JsonSerial Event where- jsonSerial _ = toEncoding- jsonValue _ = toJSON--instance BinSerial Event where- binSerial _ (EventBlock bh) = putWord8 0x00 >> put bh- binSerial _ (EventTx th) = putWord8 0x01 >> put th-- binDeserial _ = getWord8 >>=- \case- 0x00-> EventBlock <$> get- 0x01 -> EventTx <$> get- _ -> fail "Expected fst byte to be 0x00 or 0x01"---newtype TxAfterHeight = TxAfterHeight- { txAfterHeight :: Maybe Bool- } deriving (Show, Eq, Generic, NFData)--instance ToJSON TxAfterHeight where- toJSON (TxAfterHeight b) = object ["result" .= b]--instance JsonSerial TxAfterHeight where- jsonSerial _ = toEncoding- jsonValue _ = toJSON--instance BinSerial TxAfterHeight where- binSerial _ TxAfterHeight {txAfterHeight = a} = put a- binDeserial _ = TxAfterHeight <$> get--newtype TxId = TxId TxHash deriving (Show, Eq, Generic, NFData)--instance ToJSON TxId where- toJSON (TxId h) = object ["txid" .= h]--instance JsonSerial TxId where- jsonSerial _ = toEncoding- jsonValue _ = toJSON--instance BinSerial TxId where- binSerial _ (TxId th) = put th- binDeserial _ = TxId <$> get---- | Events that the store can generate.-data StoreEvent- = StoreBestBlock !BlockHash- -- ^ new best block- | StoreMempoolNew !TxHash- -- ^ new mempool transaction- | StorePeerConnected !Peer !SockAddr- -- ^ new peer connected- | StorePeerDisconnected !Peer !SockAddr- -- ^ peer has disconnected- | StorePeerPong !Peer !Word64- -- ^ peer responded 'Ping'- | StoreTxAvailable !Peer ![TxHash]- -- ^ peer inv transactions- | StoreTxReject !Peer !TxHash !RejectCode !ByteString- -- ^ peer rejected transaction- | StoreTxDeleted !TxHash- -- ^ transaction deleted from store- | StoreBlockReverted !BlockHash- -- ^ block no longer head of main chain--data PubExcept- = PubNoPeers- | PubReject RejectCode- | PubTimeout- | PubPeerDisconnected- deriving Eq--instance Show PubExcept where- show PubNoPeers = "no peers"- show (PubReject c) =- "rejected: " <>- case c of- RejectMalformed -> "malformed"- RejectInvalid -> "invalid"- RejectObsolete -> "obsolete"- RejectDuplicate -> "duplicate"- RejectNonStandard -> "not standard"- RejectDust -> "dust"- RejectInsufficientFee -> "insufficient fee"- RejectCheckpoint -> "checkpoint"- show PubTimeout = "peer timeout or silent rejection"- show PubPeerDisconnected = "peer disconnected"--instance Exception PubExcept--applyOffsetLimit :: Offset -> Maybe Limit -> [a] -> [a]-applyOffsetLimit offset limit = applyLimit limit . applyOffset offset--applyOffset :: Offset -> [a] -> [a]-applyOffset = drop . fromIntegral--applyLimit :: Maybe Limit -> [a] -> [a]-applyLimit Nothing = id-applyLimit (Just l) = take (fromIntegral l)--applyOffsetLimitC :: Monad m => Offset -> Maybe Limit -> ConduitT i i m ()-applyOffsetLimitC offset limit = applyOffsetC offset >> applyLimitC limit--applyOffsetC :: Monad m => Offset -> ConduitT i i m ()-applyOffsetC = dropC . fromIntegral--applyLimitC :: Monad m => Maybe Limit -> ConduitT i i m ()-applyLimitC Nothing = mapC id-applyLimitC (Just l) = takeC (fromIntegral l)--sortTxs :: [Tx] -> [(Word32, Tx)]-sortTxs txs = go $ zip [0 ..] txs- where- go [] = []- go ts =- let (is, ds) =- partition- (all ((`notElem` map (txHash . snd) ts) .- outPointHash . prevOutput) .- txIn . snd)- ts- in is <> go ds+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+module Haskoin.Store.Common+ ( BlockStoreMessage(..)+ , DeriveType(..)+ , Limit+ , Offset+ , BlockStore+ , UnixTime+ , getUnixTime+ , putUnixTime+ , BlockPos+ , NetWrap(..)+ , XPubSpec(..)+ , StoreRead(..)+ , StoreWrite(..)+ , BlockRef(..)+ , BlockTx(..)+ , confirmed+ , Balance(..)+ , BlockData(..)+ , StoreInput(..)+ , isCoinbase+ , Spender(..)+ , StoreOutput(..)+ , Prev(..)+ , TxData(..)+ , Unspent(..)+ , Transaction(..)+ , transactionData+ , fromTransaction+ , toTransaction+ , TxAfterHeight(..)+ , TxId(..)+ , PeerInformation(..)+ , XPubBal(..)+ , xPubBalsTxs+ , XPubUnspent(..)+ , xPubBalsUnspents+ , XPubSummary(..)+ , HealthCheck(..)+ , Event(..)+ , StoreEvent(..)+ , PubExcept(..)+ , zeroBalance+ , nullBalance+ , getTransaction+ , blockAtOrBefore+ , applyOffset+ , applyLimit+ , applyOffsetLimit+ , applyOffsetC+ , applyLimitC+ , applyOffsetLimitC+ , sortTxs+ , scriptToStringAddr+ ) where++import Conduit (ConduitT, dropC, mapC, takeC)+import Control.Applicative ((<|>))+import Control.DeepSeq (NFData)+import Control.Exception (Exception)+import Control.Monad (guard, join, mzero)+import Control.Monad.Trans (lift)+import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)+import Data.Aeson (FromJSON (..), ToJSON (..),+ Value (..), object, (.!=), (.:),+ (.:?), (.=))+import qualified Data.Aeson as A+import Data.Aeson.Types (Parser)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import Data.ByteString.Short (ShortByteString)+import qualified Data.ByteString.Short as BSS+import Data.Function (on)+import Data.Hashable (Hashable (..))+import qualified Data.IntMap as I+import Data.IntMap.Strict (IntMap)+import Data.List (nub, partition, sortBy)+import Data.Maybe (catMaybes, isJust, listToMaybe,+ mapMaybe)+import Data.Serialize (Get, Put, Serialize (..),+ getWord32be, getWord64be, getWord8,+ putWord32be, putWord64be, putWord8)+import qualified Data.Serialize as S+import Data.String.Conversions (cs)+import Data.Text (Text)+import Data.Word (Word32, Word64)+import GHC.Generics (Generic)+import Haskoin (Address, Block, BlockHash,+ BlockHeader (..), BlockHeight,+ BlockNode, BlockWork, KeyIndex,+ Network (..), OutPoint (..),+ PubKeyI (..), RejectCode (..),+ Tx (..), TxHash (..), TxIn (..),+ TxOut (..), WitnessStack,+ XPubKey (..), addrToString,+ decodeHex, deriveAddr,+ deriveCompatWitnessAddr,+ deriveWitnessAddr, eitherToMaybe,+ encodeHex, headerHash, pubSubKey,+ scriptToAddressBS, stringToAddr,+ txHash, wrapPubKey)+import Haskoin.Node (Peer)+import Network.Socket (SockAddr)+import NQE (Listen, Mailbox)+import qualified Paths_haskoin_store as P++data DeriveType+ = DeriveNormal+ | DeriveP2SH+ | DeriveP2WPKH+ deriving (Show, Eq, Generic, NFData, Serialize)++-- | Messages for block store actor.+data BlockStoreMessage+ = BlockNewBest !BlockNode+ -- ^ new block header in chain+ | BlockPeerConnect !Peer !SockAddr+ -- ^ new peer connected+ | BlockPeerDisconnect !Peer !SockAddr+ -- ^ peer disconnected+ | BlockReceived !Peer !Block+ -- ^ new block received from a peer+ | BlockNotFound !Peer ![BlockHash]+ -- ^ block not found+ | BlockTxReceived !Peer !Tx+ -- ^ transaction received from peer+ | BlockTxAvailable !Peer ![TxHash]+ -- ^ peer has transactions available+ | BlockPing !(Listen ())+ -- ^ internal housekeeping ping++-- | Mailbox for block store.+type BlockStore = Mailbox BlockStoreMessage++data XPubSpec =+ XPubSpec+ { xPubSpecKey :: !XPubKey+ , xPubDeriveType :: !DeriveType+ } deriving (Show, Eq, Generic, NFData)++instance Hashable XPubSpec where+ hashWithSalt i XPubSpec {xPubSpecKey = XPubKey {xPubKey = pubkey}} =+ hashWithSalt i pubkey++instance Serialize XPubSpec where+ put XPubSpec {xPubSpecKey = k, xPubDeriveType = t} = do+ put (xPubDepth k)+ put (xPubParent k)+ put (xPubIndex k)+ put (xPubChain k)+ put (wrapPubKey True (xPubKey k))+ put t+ get = do+ d <- get+ p <- get+ i <- get+ c <- get+ k <- get+ t <- get+ let x =+ XPubKey+ { xPubDepth = d+ , xPubParent = p+ , xPubIndex = i+ , xPubChain = c+ , xPubKey = pubKeyPoint k+ }+ return XPubSpec {xPubSpecKey = x, xPubDeriveType = t}++type DeriveAddr = XPubKey -> KeyIndex -> Address++type UnixTime = Word64+type BlockPos = Word32++type Offset = Word32+type Limit = Word32++data NetWrap a = NetWrap Network a++instance ToJSON (NetWrap a) => ToJSON (NetWrap [a]) where+ toJSON (NetWrap net xs) = toJSON $ map (toJSON . NetWrap net) xs++class Monad m =>+ StoreRead m+ where+ getNetwork :: m Network+ getBestBlock :: m (Maybe BlockHash)+ getBlocksAtHeight :: BlockHeight -> m [BlockHash]+ getBlock :: BlockHash -> m (Maybe BlockData)+ getTxData :: TxHash -> m (Maybe TxData)+ getOrphanTx :: TxHash -> m (Maybe (UnixTime, Tx))+ getOrphans :: m [(UnixTime, Tx)]+ getSpenders :: TxHash -> m (IntMap Spender)+ getSpender :: OutPoint -> m (Maybe Spender)+ getBalance :: Address -> m Balance+ getBalance a = head <$> getBalances [a]+ getBalances :: [Address] -> m [Balance]+ getBalances as = mapM getBalance as+ getAddressesTxs :: [Address] -> Maybe BlockRef -> Maybe Limit -> m [BlockTx]+ getAddressTxs :: Address -> Maybe BlockRef -> Maybe Limit -> m [BlockTx]+ getAddressTxs a = getAddressesTxs [a]+ getUnspent :: OutPoint -> m (Maybe Unspent)+ getAddressUnspents ::+ Address -> Maybe BlockRef -> Maybe Limit -> m [Unspent]+ getAddressUnspents a = getAddressesUnspents [a]+ getAddressesUnspents ::+ [Address] -> Maybe BlockRef -> Maybe Limit -> m [Unspent]+ getMempool :: m [BlockTx]+ xPubBals :: XPubSpec -> m [XPubBal]+ xPubBals xpub = do+ igap <- getInitialGap+ gap <- getMaxGap+ ext1 <- derive_until_gap gap 0 (take (fromIntegral igap) (aderiv 0 0))+ if all (nullBalance . xPubBal) ext1+ then return []+ else do+ ext2 <- derive_until_gap gap 0 (aderiv 0 igap)+ chg <- derive_until_gap gap 1 (aderiv 1 0)+ return (ext1 <> ext2 <> chg)+ where+ aderiv m n =+ deriveAddresses+ (deriveFunction (xPubDeriveType xpub))+ (pubSubKey (xPubSpecKey xpub) m)+ n+ xbalance m b n = XPubBal {xPubBalPath = [m, n], xPubBal = b}+ derive_until_gap _ _ [] = return []+ derive_until_gap gap m as = do+ let (as1, as2) = splitAt (fromIntegral gap) as+ bs <- getBalances (map snd as1)+ let xbs = zipWith (xbalance m) bs (map fst as1)+ if all nullBalance bs+ then return xbs+ else (xbs <>) <$> derive_until_gap gap m as2+ xPubSummary :: XPubSpec -> m XPubSummary+ xPubSummary xpub = do+ bs <- filter (not . nullBalance . xPubBal) <$> xPubBals xpub+ let ex = foldl max 0 [i | XPubBal {xPubBalPath = [0, i]} <- bs]+ ch = foldl max 0 [i | XPubBal {xPubBalPath = [1, i]} <- bs]+ uc =+ sum+ [ c+ | XPubBal {xPubBal = Balance {balanceUnspentCount = c}} <-+ bs+ ]+ xt = [b | b@XPubBal {xPubBalPath = [0, _]} <- bs]+ rx =+ sum+ [ r+ | XPubBal {xPubBal = Balance {balanceTotalReceived = r}} <-+ xt+ ]+ return+ XPubSummary+ { xPubSummaryConfirmed = sum (map (balanceAmount . xPubBal) bs)+ , xPubSummaryZero = sum (map (balanceZero . xPubBal) bs)+ , xPubSummaryReceived = rx+ , xPubUnspentCount = uc+ , xPubChangeIndex = ch+ , xPubExternalIndex = ex+ }+ xPubUnspents ::+ XPubSpec+ -> Maybe BlockRef+ -> Offset+ -> Maybe Limit+ -> m [XPubUnspent]+ xPubUnspents xpub start offset limit = do+ xs <- filter positive <$> xPubBals xpub+ applyOffsetLimit offset limit <$> go xs+ where+ positive XPubBal {xPubBal = Balance {balanceUnspentCount = c}} = c > 0+ go [] = return []+ go (XPubBal {xPubBalPath = p, xPubBal = Balance {balanceAddress = a}}:xs) = do+ uns <- getAddressUnspents a start limit+ let xuns =+ map+ (\t ->+ XPubUnspent {xPubUnspentPath = p, xPubUnspent = t})+ uns+ (xuns <>) <$> go xs+ xPubTxs ::+ XPubSpec -> Maybe BlockRef -> Offset -> Maybe Limit -> m [BlockTx]+ xPubTxs xpub start offset limit = do+ bs <- xPubBals xpub+ let as = map (balanceAddress . xPubBal) bs+ ts <- concat <$> mapM (\a -> getAddressTxs a start limit) as+ let ts' = nub $ sortBy (flip compare `on` blockTxBlock) ts+ return $ applyOffsetLimit offset limit ts'+ getMaxGap :: m Word32+ getInitialGap :: m Word32++class StoreWrite m where+ setBest :: BlockHash -> m ()+ insertBlock :: BlockData -> m ()+ setBlocksAtHeight :: [BlockHash] -> BlockHeight -> m ()+ insertTx :: TxData -> m ()+ insertSpender :: OutPoint -> Spender -> m ()+ deleteSpender :: OutPoint -> m ()+ insertAddrTx :: Address -> BlockTx -> m ()+ deleteAddrTx :: Address -> BlockTx -> m ()+ insertAddrUnspent :: Address -> Unspent -> m ()+ deleteAddrUnspent :: Address -> Unspent -> m ()+ setMempool :: [BlockTx] -> m ()+ insertOrphanTx :: Tx -> UnixTime -> m ()+ deleteOrphanTx :: TxHash -> m ()+ setBalance :: Balance -> m ()+ insertUnspent :: Unspent -> m ()+ deleteUnspent :: OutPoint -> m ()++deriveAddresses :: DeriveAddr -> XPubKey -> Word32 -> [(Word32, Address)]+deriveAddresses derive xpub start = map (\i -> (i, derive xpub i)) [start ..]++deriveFunction :: DeriveType -> DeriveAddr+deriveFunction DeriveNormal i = fst . deriveAddr i+deriveFunction DeriveP2SH i = fst . deriveCompatWitnessAddr i+deriveFunction DeriveP2WPKH i = fst . deriveWitnessAddr i++xPubBalsUnspents ::+ StoreRead m+ => [XPubBal]+ -> Maybe BlockRef+ -> Offset+ -> Maybe Limit+ -> m [XPubUnspent]+xPubBalsUnspents bals start offset limit = do+ let xs = filter positive bals+ applyOffsetLimit offset limit <$> go xs+ where+ positive XPubBal {xPubBal = Balance {balanceUnspentCount = c}} = c > 0+ go [] = return []+ go (XPubBal {xPubBalPath = p, xPubBal = Balance {balanceAddress = a}}:xs) = do+ uns <- getAddressUnspents a start limit+ let xuns =+ map+ (\t -> XPubUnspent {xPubUnspentPath = p, xPubUnspent = t})+ uns+ (xuns <>) <$> go xs++xPubBalsTxs ::+ StoreRead m+ => [XPubBal]+ -> Maybe BlockRef+ -> Offset+ -> Maybe Limit+ -> m [BlockTx]+xPubBalsTxs bals start offset limit = do+ let as = map balanceAddress . filter (not . nullBalance) $ map xPubBal bals+ ts <- concat <$> mapM (\a -> getAddressTxs a start limit) as+ let ts' = nub $ sortBy (flip compare `on` blockTxBlock) ts+ return $ applyOffsetLimit offset limit ts'++getTransaction ::+ (Monad m, StoreRead m) => TxHash -> m (Maybe Transaction)+getTransaction h = runMaybeT $ do+ d <- MaybeT $ getTxData h+ sm <- lift $ getSpenders h+ return $ toTransaction d sm++blockAtOrBefore :: (Monad m, StoreRead m) => UnixTime -> m (Maybe BlockData)+blockAtOrBefore q = runMaybeT $ do+ a <- g 0+ b <- MaybeT getBestBlock >>= MaybeT . getBlock+ f a b+ where+ f a b+ | t b <= q = return b+ | t a > q = mzero+ | h b - h a == 1 = return a+ | otherwise = do+ let x = h a + (h b - h a) `div` 2+ m <- g x+ if t m > q then f a m else f m b+ g x = MaybeT (listToMaybe <$> getBlocksAtHeight x) >>= MaybeT . getBlock+ h = blockDataHeight+ t = fromIntegral . blockTimestamp . blockDataHeader++-- | Serialize such that ordering is inverted.+putUnixTime :: Word64 -> Put+putUnixTime w = putWord64be $ maxBound - w++getUnixTime :: Get Word64+getUnixTime = (maxBound -) <$> getWord64be++-- | Reference to a block where a transaction is stored.+data BlockRef+ = BlockRef+ { blockRefHeight :: !BlockHeight+ -- ^ block height in the chain+ , blockRefPos :: !Word32+ -- ^ position of transaction within the block+ }+ | MemRef+ { memRefTime :: !UnixTime+ }+ deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData)++-- | Serialized entities will sort in reverse order.+instance Serialize BlockRef where+ put MemRef {memRefTime = t} = do+ putWord8 0x00+ putUnixTime t+ put BlockRef {blockRefHeight = h, blockRefPos = p} = do+ putWord8 0x01+ putWord32be (maxBound - h)+ putWord32be (maxBound - p)+ get = getmemref <|> getblockref+ where+ getmemref = do+ guard . (== 0x00) =<< getWord8+ MemRef <$> getUnixTime+ getblockref = do+ guard . (== 0x01) =<< getWord8+ h <- (maxBound -) <$> getWord32be+ p <- (maxBound -) <$> getWord32be+ return BlockRef {blockRefHeight = h, blockRefPos = p}++confirmed :: BlockRef -> Bool+confirmed BlockRef {} = True+confirmed MemRef {} = False++instance ToJSON BlockRef where+ toJSON BlockRef {blockRefHeight = h, blockRefPos = p} =+ object ["height" .= h, "position" .= p]+ toJSON MemRef {memRefTime = t} = object ["mempool" .= t]++instance FromJSON BlockRef where+ parseJSON = A.withObject "blockref" $ \o -> b o <|> m o+ where+ b o = do+ height <- o .: "height"+ position <- o .: "position"+ return BlockRef {blockRefHeight = height, blockRefPos = position}+ m o = do+ mempool <- o .: "mempool"+ return MemRef {memRefTime = mempool}++-- | Transaction in relation to an address.+data BlockTx = BlockTx+ { blockTxBlock :: !BlockRef+ -- ^ block information+ , blockTxHash :: !TxHash+ -- ^ transaction hash+ } deriving (Show, Eq, Ord, Generic, Serialize, Hashable, NFData)++instance ToJSON BlockTx where+ toJSON btx = object ["txid" .= blockTxHash btx, "block" .= blockTxBlock btx]++instance FromJSON BlockTx where+ parseJSON =+ A.withObject "blocktx" $ \o -> do+ txid <- o .: "txid"+ block <- o .: "block"+ return BlockTx {blockTxBlock = block, blockTxHash = txid}++-- | Address balance information.+data Balance =+ Balance+ { balanceAddress :: !Address+ -- ^ address balance+ , balanceAmount :: !Word64+ -- ^ confirmed balance+ , balanceZero :: !Word64+ -- ^ unconfirmed balance+ , balanceUnspentCount :: !Word64+ -- ^ number of unspent outputs+ , balanceTxCount :: !Word64+ -- ^ number of transactions+ , balanceTotalReceived :: !Word64+ -- ^ total amount from all outputs in this address+ }+ deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData)++zeroBalance :: Address -> Balance+zeroBalance a =+ Balance+ { balanceAddress = a+ , balanceAmount = 0+ , balanceUnspentCount = 0+ , balanceZero = 0+ , balanceTxCount = 0+ , balanceTotalReceived = 0+ }++nullBalance :: Balance -> Bool+nullBalance Balance { balanceAmount = 0+ , balanceUnspentCount = 0+ , balanceZero = 0+ , balanceTxCount = 0+ , balanceTotalReceived = 0+ } = True+nullBalance _ = False++instance ToJSON (NetWrap Balance) where+ toJSON (NetWrap net b) =+ object $+ [ "address" .= addrToString net (balanceAddress b)+ , "confirmed" .= balanceAmount b+ , "unconfirmed" .= balanceZero b+ , "utxo" .= balanceUnspentCount b+ , "txs" .= balanceTxCount b+ , "received" .= balanceTotalReceived b+ ]++instance FromJSON (Network -> Maybe Balance) where+ parseJSON =+ A.withObject "balance" $ \o -> do+ amount <- o .: "confirmed"+ unconfirmed <- o .: "unconfirmed"+ utxo <- o .: "utxo"+ txs <- o .: "txs"+ received <- o .: "received"+ address <- o .: "address"+ return $ \net ->+ stringToAddr net address >>= \a ->+ return+ Balance+ { balanceAddress = a+ , balanceAmount = amount+ , balanceUnspentCount = utxo+ , balanceZero = unconfirmed+ , balanceTxCount = txs+ , balanceTotalReceived = received+ }++-- | Unspent output.+data Unspent = Unspent+ { unspentBlock :: !BlockRef+ , unspentPoint :: !OutPoint+ , unspentAmount :: !Word64+ , unspentScript :: !ShortByteString+ , unspentAddress :: !(Maybe String)+ } deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData)++instance ToJSON Unspent where+ toJSON u =+ object $+ [ "address" .= unspentAddress u+ , "block" .= unspentBlock u+ , "txid" .= outPointHash (unspentPoint u)+ , "index" .= outPointIndex (unspentPoint u)+ , "pkscript" .= script+ , "value" .= unspentAmount u+ ]+ where+ bsscript = BSS.fromShort (unspentScript u)+ script = String (encodeHex bsscript)++instance FromJSON Unspent where+ parseJSON =+ A.withObject "unspent" $ \o -> do+ block <- o .: "block"+ txid <- o .: "txid"+ index <- o .: "index"+ value <- o .: "value"+ script <- BSS.toShort <$> (o .: "pkscript" >>= jsonHex)+ address <- o .: "address"+ return+ Unspent+ { unspentBlock = block+ , unspentPoint = OutPoint txid index+ , unspentAmount = value+ , unspentScript = script+ , unspentAddress = address+ }++-- | Database value for a block entry.+data BlockData = BlockData+ { blockDataHeight :: !BlockHeight+ -- ^ height of the block in the chain+ , blockDataMainChain :: !Bool+ -- ^ is this block in the main chain?+ , blockDataWork :: !BlockWork+ -- ^ accumulated work in that block+ , blockDataHeader :: !BlockHeader+ -- ^ block header+ , blockDataSize :: !Word32+ -- ^ size of the block including witnesses+ , blockDataWeight :: !Word32+ -- ^ weight of this block (for segwit networks)+ , blockDataTxs :: ![TxHash]+ -- ^ block transactions+ , blockDataOutputs :: !Word64+ -- ^ sum of all transaction outputs+ , blockDataFees :: !Word64+ -- ^ sum of all transaction fees+ , blockDataSubsidy :: !Word64+ -- ^ block subsidy+ } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData)++instance ToJSON BlockData where+ toJSON bv =+ object+ [ "hash" .= headerHash (blockDataHeader bv)+ , "height" .= blockDataHeight bv+ , "mainchain" .= blockDataMainChain bv+ , "previous" .= prevBlock (blockDataHeader bv)+ , "time" .= blockTimestamp (blockDataHeader bv)+ , "version" .= blockVersion (blockDataHeader bv)+ , "bits" .= blockBits (blockDataHeader bv)+ , "nonce" .= bhNonce (blockDataHeader bv)+ , "size" .= blockDataSize bv+ , "tx" .= blockDataTxs bv+ , "merkle" .= TxHash (merkleRoot (blockDataHeader bv))+ , "subsidy" .= blockDataSubsidy bv+ , "fees" .= blockDataFees bv+ , "outputs" .= blockDataOutputs bv+ , "work" .= String (cs (show (blockDataWork bv)))+ , "weight" .= blockDataWeight bv+ ]++instance FromJSON BlockData where+ parseJSON =+ A.withObject "blockdata" $ \o -> do+ height <- o .: "height"+ mainchain <- o .: "mainchain"+ previous <- o .: "previous"+ time <- o .: "time"+ version <- o .: "version"+ bits <- o .: "bits"+ nonce <- o .: "nonce"+ size <- o .: "size"+ tx <- o .: "tx"+ TxHash merkle <- o .: "merkle"+ subsidy <- o .: "subsidy"+ fees <- o .: "fees"+ outputs <- o .: "outputs"+ work <- o .: "work"+ weight <- o .: "weight"+ return+ BlockData+ { blockDataHeader =+ BlockHeader+ { prevBlock = previous+ , blockTimestamp = time+ , blockVersion = version+ , blockBits = bits+ , bhNonce = nonce+ , merkleRoot = merkle+ }+ , blockDataMainChain = mainchain+ , blockDataWork = read work+ , blockDataSize = size+ , blockDataWeight = weight+ , blockDataTxs = tx+ , blockDataOutputs = outputs+ , blockDataFees = fees+ , blockDataHeight = height+ , blockDataSubsidy = subsidy+ }++data StoreInput+ = StoreCoinbase { inputPoint :: !OutPoint+ , inputSequence :: !Word32+ , inputSigScript :: !ByteString+ , inputWitness :: !(Maybe WitnessStack)+ }+ | StoreInput { inputPoint :: !OutPoint+ , inputSequence :: !Word32+ , inputSigScript :: !ByteString+ , inputPkScript :: !ByteString+ , inputAmount :: !Word64+ , inputWitness :: !(Maybe WitnessStack)+ }+ deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData)++isCoinbase :: StoreInput -> Bool+isCoinbase StoreCoinbase {} = True+isCoinbase StoreInput {} = False++instance ToJSON (NetWrap StoreInput) where+ toJSON (NetWrap net StoreInput { inputPoint = OutPoint oph opi+ , inputSequence = sq+ , inputSigScript = ss+ , inputPkScript = ps+ , inputAmount = val+ , inputWitness = wit+ }) =+ object+ [ "coinbase" .= False+ , "txid" .= oph+ , "output" .= opi+ , "sigscript" .= String (encodeHex ss)+ , "sequence" .= sq+ , "pkscript" .= String (encodeHex ps)+ , "value" .= val+ , "address" .= scriptToStringAddr net ps+ , "witness" .= fmap (map encodeHex) wit+ ]+ toJSON (NetWrap _ StoreCoinbase { inputPoint = OutPoint oph opi+ , inputSequence = sq+ , inputSigScript = ss+ , inputWitness = wit+ }) =+ object+ [ "coinbase" .= True+ , "txid" .= oph+ , "output" .= opi+ , "sigscript" .= String (encodeHex ss)+ , "sequence" .= sq+ , "pkscript" .= Null+ , "value" .= Null+ , "address" .= Null+ , "witness" .= fmap (map encodeHex) wit+ ]++instance FromJSON StoreInput where+ parseJSON =+ A.withObject "storeinput" $ \o -> do+ coinbase <- o .: "coinbase"+ outpoint <- OutPoint <$> o .: "txid" <*> o .: "output"+ sequ <- o .: "sequence"+ witness <-+ o .:? "witness" >>= \mmxs ->+ case join mmxs of+ Nothing -> return Nothing+ Just xs -> Just <$> mapM jsonHex xs+ sigscript <- o .: "sigscript" >>= jsonHex+ if coinbase+ then return+ StoreCoinbase+ { inputPoint = outpoint+ , inputSequence = sequ+ , inputSigScript = sigscript+ , inputWitness = witness+ }+ else do+ pkscript <- o .: "pkscript" >>= jsonHex+ value <- o .: "value"+ return+ StoreInput+ { inputPoint = outpoint+ , inputSequence = sequ+ , inputSigScript = sigscript+ , inputPkScript = pkscript+ , inputAmount = value+ , inputWitness = witness+ }++jsonHex :: Text -> Parser ByteString+jsonHex s =+ case decodeHex s of+ Nothing -> fail "Could not decode hex"+ Just b -> return b++-- | Information about input spending output.+data Spender = Spender+ { spenderHash :: !TxHash+ -- ^ input transaction hash+ , spenderIndex :: !Word32+ -- ^ input position in transaction+ } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData)++instance ToJSON Spender where+ toJSON n = object ["txid" .= spenderHash n, "input" .= spenderIndex n]++instance FromJSON Spender where+ parseJSON =+ A.withObject "spender" $ \o -> Spender <$> o .: "txid" <*> o .: "input"++-- | Output information.+data StoreOutput = StoreOutput+ { outputAmount :: !Word64+ , outputScript :: !ByteString+ , outputSpender :: !(Maybe Spender)+ } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData)++instance ToJSON (NetWrap StoreOutput) where+ toJSON (NetWrap net d) =+ object+ [ "address" .= scriptToStringAddr net (outputScript d)+ , "pkscript" .= String (encodeHex (outputScript d))+ , "value" .= outputAmount d+ , "spent" .= isJust (outputSpender d)+ , "spender" .= outputSpender d+ ]++instance FromJSON StoreOutput where+ parseJSON =+ A.withObject "storeoutput" $ \o -> do+ value <- o .: "value"+ pkscript <- o .: "pkscript" >>= jsonHex+ spender <- o .: "spender"+ return+ StoreOutput+ { outputAmount = value+ , outputScript = pkscript+ , outputSpender = spender+ }++data Prev = Prev+ { prevScript :: !ByteString+ , prevAmount :: !Word64+ } deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData)++toInput :: TxIn -> Maybe Prev -> Maybe WitnessStack -> StoreInput+toInput i Nothing w =+ StoreCoinbase+ { inputPoint = prevOutput i+ , inputSequence = txInSequence i+ , inputSigScript = scriptInput i+ , inputWitness = w+ }+toInput i (Just p) w =+ StoreInput+ { inputPoint = prevOutput i+ , inputSequence = txInSequence i+ , inputSigScript = scriptInput i+ , inputPkScript = prevScript p+ , inputAmount = prevAmount p+ , inputWitness = w+ }++toOutput :: TxOut -> Maybe Spender -> StoreOutput+toOutput o s =+ StoreOutput+ { outputAmount = outValue o+ , outputScript = scriptOutput o+ , outputSpender = s+ }++data TxData = TxData+ { txDataBlock :: !BlockRef+ , txData :: !Tx+ , txDataPrevs :: !(IntMap Prev)+ , txDataDeleted :: !Bool+ , txDataRBF :: !Bool+ , txDataTime :: !Word64+ } deriving (Show, Eq, Ord, Generic, Serialize, NFData)++toTransaction :: TxData -> IntMap Spender -> Transaction+toTransaction t sm =+ Transaction+ { transactionBlock = txDataBlock t+ , transactionVersion = txVersion (txData t)+ , transactionLockTime = txLockTime (txData t)+ , transactionInputs = ins+ , transactionOutputs = outs+ , transactionDeleted = txDataDeleted t+ , transactionRBF = txDataRBF t+ , transactionTime = txDataTime t+ }+ where+ ws =+ take (length (txIn (txData t))) $+ map Just (txWitness (txData t)) <> repeat Nothing+ f n i = toInput i (I.lookup n (txDataPrevs t)) (ws !! n)+ ins = zipWith f [0 ..] (txIn (txData t))+ g n o = toOutput o (I.lookup n sm)+ outs = zipWith g [0 ..] (txOut (txData t))++fromTransaction :: Transaction -> (TxData, IntMap Spender)+fromTransaction t = (d, sm)+ where+ d =+ TxData+ { txDataBlock = transactionBlock t+ , txData = transactionData t+ , txDataPrevs = ps+ , txDataDeleted = transactionDeleted t+ , txDataRBF = transactionRBF t+ , txDataTime = transactionTime t+ }+ f _ StoreCoinbase {} = Nothing+ f n StoreInput {inputPkScript = s, inputAmount = v} =+ Just (n, Prev {prevScript = s, prevAmount = v})+ ps = I.fromList . catMaybes $ zipWith f [0 ..] (transactionInputs t)+ g _ StoreOutput {outputSpender = Nothing} = Nothing+ g n StoreOutput {outputSpender = Just s} = Just (n, s)+ sm = I.fromList . catMaybes $ zipWith g [0 ..] (transactionOutputs t)++-- | Detailed transaction information.+data Transaction = Transaction+ { transactionBlock :: !BlockRef+ -- ^ block information for this transaction+ , transactionVersion :: !Word32+ -- ^ transaction version+ , transactionLockTime :: !Word32+ -- ^ lock time+ , transactionInputs :: ![StoreInput]+ -- ^ transaction inputs+ , transactionOutputs :: ![StoreOutput]+ -- ^ transaction outputs+ , transactionDeleted :: !Bool+ -- ^ this transaction has been deleted and is no longer valid+ , transactionRBF :: !Bool+ -- ^ this transaction can be replaced in the mempool+ , transactionTime :: !Word64+ -- ^ time the transaction was first seen or time of block+ } deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData)++transactionData :: Transaction -> Tx+transactionData t =+ Tx+ { txVersion = transactionVersion t+ , txIn = map i (transactionInputs t)+ , txOut = map o (transactionOutputs t)+ , txWitness = mapMaybe inputWitness (transactionInputs t)+ , txLockTime = transactionLockTime t+ }+ where+ i StoreCoinbase {inputPoint = p, inputSequence = q, inputSigScript = s} =+ TxIn {prevOutput = p, scriptInput = s, txInSequence = q}+ i StoreInput {inputPoint = p, inputSequence = q, inputSigScript = s} =+ TxIn {prevOutput = p, scriptInput = s, txInSequence = q}+ o StoreOutput {outputAmount = v, outputScript = s} =+ TxOut {outValue = v, scriptOutput = s}++instance ToJSON (NetWrap Transaction) where+ toJSON (NetWrap net dtx) =+ object+ [ "txid" .= txHash (transactionData dtx)+ , "size" .= B.length (S.encode (transactionData dtx))+ , "version" .= transactionVersion dtx+ , "locktime" .= transactionLockTime dtx+ , "fee" .=+ if any isCoinbase (transactionInputs dtx)+ then 0+ else inv - outv+ , "inputs" .= map (NetWrap net) (transactionInputs dtx)+ , "outputs" .= map (NetWrap net) (transactionOutputs dtx)+ , "block" .= transactionBlock dtx+ , "deleted" .= transactionDeleted dtx+ , "time" .= transactionTime dtx+ , "rbf" .= transactionRBF dtx+ , "weight" .= w+ ]+ where+ inv = sum (map inputAmount (transactionInputs dtx))+ outv = sum (map outputAmount (transactionOutputs dtx))+ w =+ let b = B.length $ S.encode (transactionData dtx) {txWitness = []}+ x = B.length $ S.encode (transactionData dtx)+ in b * 3 + x++instance FromJSON Transaction where+ parseJSON =+ A.withObject "transaction" $ \o -> do+ version <- o .: "version"+ locktime <- o .: "locktime"+ inputs <- o .: "inputs"+ outputs <- o .: "outputs"+ block <- o .: "block"+ deleted <- o .: "deleted"+ time <- o .: "time"+ rbf <- o .:? "rbf" .!= False+ return+ Transaction+ { transactionBlock = block+ , transactionVersion = version+ , transactionLockTime = locktime+ , transactionInputs = inputs+ , transactionOutputs = outputs+ , transactionDeleted = deleted+ , transactionTime = time+ , transactionRBF = rbf+ }++-- | Information about a connected peer.+data PeerInformation+ = PeerInformation { peerUserAgent :: !ByteString+ -- ^ user agent string+ , peerAddress :: !String+ -- ^ network address+ , peerVersion :: !Word32+ -- ^ version number+ , peerServices :: !Word64+ -- ^ services field+ , peerRelay :: !Bool+ -- ^ will relay transactions+ }+ deriving (Show, Eq, Ord, Generic, NFData, Serialize)++instance ToJSON PeerInformation where+ toJSON p = object+ [ "useragent" .= String (cs (peerUserAgent p))+ , "address" .= peerAddress p+ , "version" .= peerVersion p+ , "services" .= String (encodeHex (S.encode (peerServices p)))+ , "relay" .= peerRelay p+ ]++instance FromJSON PeerInformation where+ parseJSON =+ A.withObject "peerinformation" $ \o -> do+ String useragent <- o .: "useragent"+ address <- o .: "address"+ version <- o .: "version"+ services <-+ o .: "services" >>= jsonHex >>= \b ->+ case S.decode b of+ Left e -> fail $ "Could not decode services: " <> e+ Right s -> return s+ relay <- o .: "relay"+ return+ PeerInformation+ { peerUserAgent = cs useragent+ , peerAddress = address+ , peerVersion = version+ , peerServices = services+ , peerRelay = relay+ }++-- | Address balances for an extended public key.+data XPubBal = XPubBal+ { xPubBalPath :: ![KeyIndex]+ , xPubBal :: !Balance+ } deriving (Show, Ord, Eq, Generic, Serialize, NFData)++instance ToJSON (NetWrap XPubBal) where+ toJSON (NetWrap net XPubBal {xPubBalPath = p, xPubBal = b}) =+ object ["path" .= p, "balance" .= toJSON (NetWrap net b)]++-- | Unspent transaction for extended public key.+data XPubUnspent = XPubUnspent+ { xPubUnspentPath :: ![KeyIndex]+ , xPubUnspent :: !Unspent+ } deriving (Show, Eq, Generic, Serialize, NFData)++instance ToJSON XPubUnspent where+ toJSON XPubUnspent {xPubUnspentPath = p, xPubUnspent = u} =+ object ["path" .= p, "unspent" .= toJSON u]++data XPubSummary =+ XPubSummary+ { xPubSummaryConfirmed :: !Word64+ , xPubSummaryZero :: !Word64+ , xPubSummaryReceived :: !Word64+ , xPubUnspentCount :: !Word64+ , xPubExternalIndex :: !Word32+ , xPubChangeIndex :: !Word32+ }+ deriving (Eq, Show, Generic, Serialize, NFData)++instance ToJSON XPubSummary where+ toJSON XPubSummary { xPubSummaryConfirmed = c+ , xPubSummaryZero = z+ , xPubSummaryReceived = r+ , xPubUnspentCount = u+ , xPubExternalIndex = ext+ , xPubChangeIndex = ch+ } =+ object+ [ "balance" .=+ object+ [ "confirmed" .= c+ , "unconfirmed" .= z+ , "received" .= r+ , "utxo" .= u+ ]+ , "indices" .= object ["change" .= ch, "external" .= ext]+ ]++instance FromJSON XPubSummary where+ parseJSON =+ A.withObject "xpubsummary" $ \o -> do+ b <- o .: "balance"+ i <- o .: "indices"+ conf <- b .: "confirmed"+ unconfirmed <- b .: "unconfirmed"+ received <- b .: "received"+ utxo <- b .: "utxo"+ change <- i .: "change"+ external <- i .: "external"+ return+ XPubSummary+ { xPubSummaryConfirmed = conf+ , xPubSummaryZero = unconfirmed+ , xPubSummaryReceived = received+ , xPubUnspentCount = utxo+ , xPubExternalIndex = external+ , xPubChangeIndex = change+ }++data HealthCheck =+ HealthCheck+ { healthHeaderBest :: !(Maybe BlockHash)+ , healthHeaderHeight :: !(Maybe BlockHeight)+ , healthBlockBest :: !(Maybe BlockHash)+ , healthBlockHeight :: !(Maybe BlockHeight)+ , healthPeers :: !(Maybe Int)+ , healthNetwork :: !String+ , healthOK :: !Bool+ , healthSynced :: !Bool+ , healthLastBlock :: !(Maybe Word64)+ , healthLastTx :: !(Maybe Word64)+ }+ deriving (Show, Eq, Generic, Serialize, NFData)++instance ToJSON HealthCheck where+ toJSON h =+ object+ [ "headers" .=+ object+ [ "hash" .= healthHeaderBest h+ , "height" .= healthHeaderHeight h+ ]+ , "blocks" .=+ object+ ["hash" .= healthBlockBest h, "height" .= healthBlockHeight h]+ , "peers" .= healthPeers h+ , "net" .= healthNetwork h+ , "ok" .= healthOK h+ , "synced" .= healthSynced h+ , "version" .= P.version+ , "lastblock" .= healthLastBlock h+ , "lasttx" .= healthLastTx h+ ]++instance FromJSON HealthCheck where+ parseJSON =+ A.withObject "healthcheck" $ \o -> do+ headers <- o .: "headers"+ headers_hash <- headers .: "hash"+ headers_height <- headers .: "height"+ blocks <- o .: "blocks"+ blocks_hash <- blocks .: "hash"+ blocks_height <- blocks .: "height"+ peers <- o .: "peers"+ net <- o .: "net"+ ok <- o .: "ok"+ synced <- o .: "synced"+ lastblock <- o .: "lastblock"+ lasttx <- o .: "lasttx"+ return+ HealthCheck+ { healthHeaderBest = headers_hash+ , healthHeaderHeight = headers_height+ , healthBlockBest = blocks_hash+ , healthBlockHeight = blocks_height+ , healthPeers = peers+ , healthNetwork = net+ , healthOK = ok+ , healthSynced = synced+ , healthLastBlock = lastblock+ , healthLastTx = lasttx+ }++data Event+ = EventBlock BlockHash+ | EventTx TxHash+ deriving (Show, Eq, Generic, Serialize, NFData)++instance ToJSON Event where+ toJSON (EventTx h) = object ["type" .= String "tx", "id" .= h]+ toJSON (EventBlock h) = object ["type" .= String "block", "id" .= h]++instance FromJSON Event where+ parseJSON =+ A.withObject "event" $ \o -> do+ t <- o .: "type"+ case t of+ "tx" -> do+ i <- o .: "id"+ return $ EventTx i+ "block" -> do+ i <- o .: "id"+ return $ EventBlock i+ _ -> fail $ "Could not recognize event type: " <> t++newtype TxAfterHeight = TxAfterHeight+ { txAfterHeight :: Maybe Bool+ } deriving (Show, Eq, Generic, Serialize, NFData)++instance ToJSON TxAfterHeight where+ toJSON (TxAfterHeight b) = object ["result" .= b]++instance FromJSON TxAfterHeight where+ parseJSON =+ A.withObject "txafterheight" $ \o -> TxAfterHeight <$> o .: "result"++newtype TxId =+ TxId TxHash+ deriving (Show, Eq, Generic, Serialize, NFData)++instance ToJSON TxId where+ toJSON (TxId h) = object ["txid" .= h]++instance FromJSON TxId where+ parseJSON = A.withObject "txid" $ \o -> TxId <$> o .: "txid"++-- | Events that the store can generate.+data StoreEvent+ = StoreBestBlock !BlockHash+ -- ^ new best block+ | StoreMempoolNew !TxHash+ -- ^ new mempool transaction+ | StorePeerConnected !Peer !SockAddr+ -- ^ new peer connected+ | StorePeerDisconnected !Peer !SockAddr+ -- ^ peer has disconnected+ | StorePeerPong !Peer !Word64+ -- ^ peer responded 'Ping'+ | StoreTxAvailable !Peer ![TxHash]+ -- ^ peer inv transactions+ | StoreTxReject !Peer !TxHash !RejectCode !ByteString+ -- ^ peer rejected transaction+ | StoreTxDeleted !TxHash+ -- ^ transaction deleted from store+ | StoreBlockReverted !BlockHash+ -- ^ block no longer head of main chain++data PubExcept+ = PubNoPeers+ | PubReject RejectCode+ | PubTimeout+ | PubPeerDisconnected+ deriving (Eq, NFData, Generic, Serialize)++instance Show PubExcept where+ show PubNoPeers = "no peers"+ show (PubReject c) =+ "rejected: " <>+ case c of+ RejectMalformed -> "malformed"+ RejectInvalid -> "invalid"+ RejectObsolete -> "obsolete"+ RejectDuplicate -> "duplicate"+ RejectNonStandard -> "not standard"+ RejectDust -> "dust"+ RejectInsufficientFee -> "insufficient fee"+ RejectCheckpoint -> "checkpoint"+ show PubTimeout = "peer timeout or silent rejection"+ show PubPeerDisconnected = "peer disconnected"++instance Exception PubExcept++applyOffsetLimit :: Offset -> Maybe Limit -> [a] -> [a]+applyOffsetLimit offset limit = applyLimit limit . applyOffset offset++applyOffset :: Offset -> [a] -> [a]+applyOffset = drop . fromIntegral++applyLimit :: Maybe Limit -> [a] -> [a]+applyLimit Nothing = id+applyLimit (Just l) = take (fromIntegral l)++applyOffsetLimitC :: Monad m => Offset -> Maybe Limit -> ConduitT i i m ()+applyOffsetLimitC offset limit = applyOffsetC offset >> applyLimitC limit++applyOffsetC :: Monad m => Offset -> ConduitT i i m ()+applyOffsetC = dropC . fromIntegral++applyLimitC :: Monad m => Maybe Limit -> ConduitT i i m ()+applyLimitC Nothing = mapC id+applyLimitC (Just l) = takeC (fromIntegral l)++sortTxs :: [Tx] -> [(Word32, Tx)]+sortTxs txs = go $ zip [0 ..] txs+ where+ go [] = []+ go ts =+ let (is, ds) =+ partition+ (all ((`notElem` map (txHash . snd) ts) .+ outPointHash . prevOutput) .+ txIn . snd)+ ts+ in is <> go ds++scriptToStringAddr :: Network -> ByteString -> Maybe String+scriptToStringAddr net bs =+ cs <$> (addrToString net =<< eitherToMaybe (scriptToAddressBS bs))
src/Haskoin/Store/Database/Memory.hs view
@@ -25,14 +25,15 @@ isJust) import Data.Word (Word32) import Haskoin (Address, BlockHash, BlockHeight,- OutPoint (..), Tx, TxHash,- headerHash, txHash)-import Haskoin.Store.Common (Balance, BlockData (..),+ Network, OutPoint (..), Tx,+ TxHash, headerHash, txHash)+import Haskoin.Store.Common (Balance (..), BlockData (..), BlockRef, BlockTx (..), Limit, Spender, StoreRead (..), StoreWrite (..), TxData (..), UnixTime, Unspent (..),- applyLimit, zeroBalance)+ applyLimit, scriptToStringAddr,+ zeroBalance) import Haskoin.Store.Database.Types (BalVal, OutVal (..), UnspentVal, balanceToVal, unspentToVal, valToBalance, valToUnspent)@@ -40,8 +41,10 @@ data MemoryState = MemoryState- { memoryDatabase :: !(TVar MemoryDatabase)- , memoryMaxGap :: !Word32+ { memoryDatabase :: !(TVar MemoryDatabase)+ , memoryMaxGap :: !Word32+ , memoryInitialGap :: !Word32+ , memoryNetwork :: !Network } withMemoryDatabase ::@@ -102,8 +105,9 @@ getSpendersH t = M.lookupDefault I.empty t . hSpender getBalanceH :: Address -> MemoryDatabase -> Balance-getBalanceH a =- fromMaybe (zeroBalance a) . fmap (valToBalance a) . M.lookup a . hBalance+getBalanceH a mem =+ fromMaybe (zeroBalance a) . fmap (valToBalance a) . M.lookup a $+ hBalance mem getMempoolH :: MemoryDatabase -> Maybe [BlockTx] getMempoolH = hMempool@@ -139,16 +143,21 @@ Just br -> b > br getAddressesUnspentsH ::- [Address] -> Maybe BlockRef -> Maybe Limit -> MemoryDatabase -> [Unspent]-getAddressesUnspentsH addrs start limit db = applyLimit limit xs+ Network+ -> [Address]+ -> Maybe BlockRef+ -> Maybe Limit+ -> MemoryDatabase+ -> [Unspent]+getAddressesUnspentsH net addrs start limit db = applyLimit limit xs where xs = nub . sortBy (flip compare `on` unspentBlock) . concat $- map (\a -> getAddressUnspentsH a start limit db) addrs+ map (\a -> getAddressUnspentsH net a start limit db) addrs getAddressUnspentsH ::- Address -> Maybe BlockRef -> Maybe Limit -> MemoryDatabase -> [Unspent]-getAddressUnspentsH addr start limit db =+ Network -> Address -> Maybe BlockRef -> Maybe Limit -> MemoryDatabase -> [Unspent]+getAddressUnspentsH net addr start limit db = applyLimit limit . dropWhile h . sortBy (flip compare) . catMaybes . concatMap (uncurry f) . M.toList $@@ -162,6 +171,7 @@ , unspentAmount = outValAmount u , unspentScript = B.Short.toShort (outValScript u) , unspentPoint = p+ , unspentAddress = scriptToStringAddr net (outValScript u) } g _ _ Nothing = Nothing h Unspent {unspentBlock = b} =@@ -205,9 +215,10 @@ } setBalanceH :: Balance -> MemoryDatabase -> MemoryDatabase-setBalanceH bal db = db {hBalance = M.insert a b (hBalance db)}+setBalanceH bal db =+ db {hBalance = M.insert (balanceAddress bal) b (hBalance db)} where- (a, b) = balanceToVal bal+ b = balanceToVal bal insertAddrTxH :: Address -> BlockTx -> MemoryDatabase -> MemoryDatabase insertAddrTxH a btx db =@@ -264,10 +275,10 @@ deleteOrphanTxH :: TxHash -> MemoryDatabase -> MemoryDatabase deleteOrphanTxH h db = db {hOrphans = M.insert h Nothing (hOrphans db)} -getUnspentH :: OutPoint -> MemoryDatabase -> Maybe (Maybe Unspent)-getUnspentH op db = do+getUnspentH :: Network -> OutPoint -> MemoryDatabase -> Maybe (Maybe Unspent)+getUnspentH net op db = do m <- M.lookup (outPointHash op) (hUnspent db)- fmap (valToUnspent op) <$> I.lookup (fromIntegral (outPointIndex op)) m+ fmap (valToUnspent net op) <$> I.lookup (fromIntegral (outPointIndex op)) m insertUnspentH :: Unspent -> MemoryDatabase -> MemoryDatabase insertUnspentH u db =@@ -317,7 +328,8 @@ return . join $ getOrphanTxH h v getUnspent p = do v <- R.asks memoryDatabase >>= readTVarIO- return . join $ getUnspentH p v+ net <- R.asks memoryNetwork+ return . join $ getUnspentH net p v getBalance a = do v <- R.asks memoryDatabase >>= readTVarIO return $ getBalanceH a v@@ -329,7 +341,8 @@ return $ getAddressesTxsH addr start limit v getAddressesUnspents addr start limit = do v <- R.asks memoryDatabase >>= readTVarIO- return $ getAddressesUnspentsH addr start limit v+ net <- R.asks memoryNetwork+ return $ getAddressesUnspentsH net addr start limit v getOrphans = do v <- R.asks memoryDatabase >>= readTVarIO return $ getOrphansH v@@ -338,8 +351,11 @@ return $ getAddressTxsH addr start limit v getAddressUnspents addr start limit = do v <- R.asks memoryDatabase >>= readTVarIO- return $ getAddressUnspentsH addr start limit v+ net <- R.asks memoryNetwork+ return $ getAddressUnspentsH net addr start limit v getMaxGap = R.asks memoryMaxGap+ getInitialGap = R.asks memoryInitialGap+ getNetwork = R.asks memoryNetwork instance MonadIO m => StoreWrite (ReaderT MemoryState m) where setBest h = do
src/Haskoin/Store/Database/Reader.hs view
@@ -24,7 +24,8 @@ import Database.RocksDB.Query (insert, matching, matchingAsList, matchingSkip, retrieve) import Haskoin (Address, BlockHash, BlockHeight,- OutPoint (..), Tx, TxHash)+ Network, OutPoint (..), Tx,+ TxHash) import Haskoin.Store.Common (Balance, BlockData, BlockRef (..), BlockTx (..), Limit, Spender, StoreRead (..),@@ -48,13 +49,16 @@ { databaseHandle :: !DB , databaseReadOptions :: !ReadOptions , databaseMaxGap :: !Word32+ , databaseInitialGap :: !Word32+ , databaseNetwork :: !Network } dataVersion :: Word32 dataVersion = 16 -connectRocksDB :: MonadIO m => Word32 -> FilePath -> m DatabaseReader-connectRocksDB gap dir = do+connectRocksDB ::+ MonadIO m => Network -> Word32 -> Word32 -> FilePath -> m DatabaseReader+connectRocksDB net igap gap dir = do db <- open dir@@ -69,6 +73,8 @@ { databaseReadOptions = defaultReadOptions , databaseHandle = db , databaseMaxGap = gap+ , databaseNetwork = net+ , databaseInitialGap = igap } initRocksDB bdb return bdb@@ -132,7 +138,9 @@ f _ _ = undefined getBalanceDB :: MonadIO m => Address -> DatabaseReader -> m Balance-getBalanceDB a DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =+getBalanceDB a DatabaseReader { databaseReadOptions = opts+ , databaseHandle = db+ } = fromMaybe (zeroBalance a) . fmap (valToBalance a) <$> retrieve db opts (BalKey a) @@ -185,8 +193,11 @@ f _ _ = undefined getUnspentDB :: MonadIO m => OutPoint -> DatabaseReader -> m (Maybe Unspent)-getUnspentDB p DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =- fmap (valToUnspent p) <$> retrieve db opts (UnspentKey p)+getUnspentDB p DatabaseReader { databaseReadOptions = opts+ , databaseHandle = db+ , databaseNetwork = net+ } =+ fmap (valToUnspent net p) <$> retrieve db opts (UnspentKey p) getAddressesUnspentsDB :: MonadIO m@@ -207,9 +218,12 @@ -> Maybe Limit -> DatabaseReader -> m [Unspent]-getAddressUnspentsDB a start limit DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =+getAddressUnspentsDB a start limit DatabaseReader { databaseReadOptions = opts+ , databaseHandle = db+ , databaseNetwork = net+ } = liftIO . runResourceT . runConduit $- x .| applyLimitC limit .| mapC (uncurry toUnspent) .| sinkList+ x .| applyLimitC limit .| mapC (uncurry (toUnspent net)) .| sinkList where x = case start of@@ -217,6 +231,7 @@ Just br -> matchingSkip db opts (AddrOutKeyA a) (AddrOutKeyB a br) instance MonadIO m => StoreRead (DatabaseReaderT m) where+ getNetwork = asks databaseNetwork getBestBlock = ask >>= getBestDatabaseReader getBlocksAtHeight h = ask >>= getBlocksAtHeightDB h getBlock b = ask >>= getDatabaseReader b@@ -235,3 +250,4 @@ getAddressUnspents a b c = ask >>= getAddressUnspentsDB a b c getAddressTxs a b c = ask >>= getAddressTxsDB a b c getMaxGap = asks databaseMaxGap+ getInitialGap = asks databaseInitialGap
src/Haskoin/Store/Database/Types.hs view
@@ -40,11 +40,11 @@ import Database.RocksDB.Query (Key, KeyValue) import GHC.Generics (Generic) import Haskoin (Address, BlockHash, BlockHeight,- OutPoint (..), Tx, TxHash)+ Network, OutPoint (..), Tx, TxHash) import Haskoin.Store.Common (Balance (..), BlockData, BlockRef, BlockTx (..), Spender, TxData, UnixTime, Unspent (..), getUnixTime,- putUnixTime)+ putUnixTime, scriptToStringAddr) -- | Database key for an address transaction. data AddrTxKey@@ -215,17 +215,15 @@ instance Key UnspentKey instance KeyValue UnspentKey UnspentVal -toUnspent :: AddrOutKey -> OutVal -> Unspent-toUnspent AddrOutKey {addrOutKeyB = b, addrOutKeyP = p} OutVal { outValAmount = v- , outValScript = s- } =+toUnspent :: Network -> AddrOutKey -> OutVal -> Unspent+toUnspent net b v = Unspent- { unspentBlock = b- , unspentAmount = v- , unspentScript = BSS.toShort s- , unspentPoint = p+ { unspentBlock = addrOutKeyB b+ , unspentAmount = outValAmount v+ , unspentScript = BSS.toShort (outValScript v)+ , unspentPoint = addrOutKeyP b+ , unspentAddress = scriptToStringAddr net (outValScript v) }-toUnspent _ _ = undefined -- | Mempool transaction database key. data MemKey =@@ -407,22 +405,20 @@ , balanceTotalReceived = r } -balanceToVal :: Balance -> (Address, BalVal)-balanceToVal Balance { balanceAddress = a- , balanceAmount = v+balanceToVal :: Balance -> BalVal+balanceToVal Balance { balanceAmount = v , balanceZero = z , balanceUnspentCount = u , balanceTxCount = t , balanceTotalReceived = r } =- ( a- , BalVal- { balValAmount = v- , balValZero = z- , balValUnspentCount = u- , balValTxCount = t- , balValTotalReceived = r- })+ BalVal+ { balValAmount = v+ , balValZero = z+ , balValUnspentCount = u+ , balValTxCount = t+ , balValTotalReceived = r+ } -- | Default balance for an address. instance Default BalVal where@@ -451,14 +447,15 @@ , UnspentVal {unspentValBlock = b, unspentValAmount = v, unspentValScript = s}) -valToUnspent :: OutPoint -> UnspentVal -> Unspent-valToUnspent p UnspentVal { unspentValBlock = b- , unspentValAmount = v- , unspentValScript = s- } =+valToUnspent :: Network -> OutPoint -> UnspentVal -> Unspent+valToUnspent net p UnspentVal { unspentValBlock = b+ , unspentValAmount = v+ , unspentValScript = s+ } = Unspent { unspentBlock = b , unspentPoint = p , unspentAmount = v , unspentScript = s+ , unspentAddress = scriptToStringAddr net (BSS.fromShort s) }
src/Haskoin/Store/Database/Writer.hs view
@@ -58,9 +58,19 @@ => DatabaseReader -> ReaderT DatabaseWriter m a -> m a-runDatabaseWriter bdb@DatabaseReader {databaseHandle = db, databaseMaxGap = gap} f = do+runDatabaseWriter bdb@DatabaseReader { databaseHandle = db+ , databaseMaxGap = gap+ , databaseInitialGap = igap+ , databaseNetwork = net+ } f = do hm <- newTVarIO emptyMemoryDatabase- let ms = MemoryState {memoryDatabase = hm, memoryMaxGap = gap}+ let ms =+ MemoryState+ { memoryDatabase = hm+ , memoryMaxGap = gap+ , memoryNetwork = net+ , memoryInitialGap = igap+ } x <- R.runReaderT f@@ -275,7 +285,9 @@ return . I.map fromJust . I.filter isJust $ hsm <> dsm getBalanceI :: MonadIO m => Address -> DatabaseWriter -> m Balance-getBalanceI a DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} =+getBalanceI a DatabaseWriter { databaseWriterReader = db+ , databaseWriterState = hm+ } = fromMaybe (zeroBalance a) <$> runMaybeT (MaybeT f <|> MaybeT g) where f =@@ -298,10 +310,12 @@ withMemoryDatabase hm $ setBalance b getUnspentI :: MonadIO m => OutPoint -> DatabaseWriter -> m (Maybe Unspent)-getUnspentI op DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} =- fmap join . runMaybeT $ MaybeT f <|> MaybeT g+getUnspentI op DatabaseWriter { databaseWriterReader = db+ , databaseWriterState = hm+ } = fmap join . runMaybeT $ MaybeT f <|> MaybeT g where- f = getUnspentH op <$> readTVarIO (memoryDatabase hm)+ net = databaseNetwork db+ f = getUnspentH net op <$> readTVarIO (memoryDatabase hm) g = Just <$> withDatabaseReader db (getUnspent op) insertUnspentI :: MonadIO m => Unspent -> DatabaseWriter -> m ()@@ -322,6 +336,8 @@ Nothing -> withDatabaseReader db getMempool instance MonadIO m => StoreRead (ReaderT DatabaseWriter m) where+ getInitialGap = R.asks (databaseInitialGap . databaseWriterReader)+ getNetwork = R.asks (databaseNetwork . databaseWriterReader) getBestBlock = R.ask >>= getBestBlockI getBlocksAtHeight h = R.ask >>= getBlocksAtHeightI h getBlock b = R.ask >>= getBlockI b
src/Haskoin/Store/Logic.hs view
@@ -38,10 +38,11 @@ OutPoint (..), Tx (..), TxHash, TxIn (..), TxOut (..), addrToString, blockHashToHex,- genesisBlock, genesisNode,- headerHash, isGenesis,- nullOutPoint, scriptToAddressBS,- txHash, txHashToHex)+ genesisBlock,+ genesisNode, headerHash,+ isGenesis, nullOutPoint,+ scriptToAddressBS, txHash,+ txHashToHex) import Haskoin.Store.Common (Balance (..), BlockData (..), BlockRef (..), BlockTx (..), Prev (..), Spender (..),@@ -52,8 +53,8 @@ UnixTime, Unspent (..), confirmed, fromTransaction, isCoinbase, nullBalance,- sortTxs, toTransaction,- transactionData)+ scriptToStringAddr, sortTxs,+ toTransaction, transactionData) import Network.Haskoin.Block.Headers (computeSubsidy) import UnliftIO (Exception) @@ -86,13 +87,13 @@ , MonadLogger m , MonadError ImportException m )- => Network- -> m ()-initBest net = do+ => m ()+initBest = do+ net <- getNetwork m <- getBestBlock when (isNothing m)- (void (importBlock net (genesisBlock net) (genesisNode net)))+ (void (importBlock (genesisBlock net) (genesisNode net))) getOldOrphans :: StoreRead m => UnixTime -> m [TxHash] getOldOrphans now =@@ -109,16 +110,15 @@ , MonadLogger m , MonadError ImportException m )- => Network- -> UnixTime+ => UnixTime -> Tx -> m (Maybe [TxHash]) -- ^ deleted transactions or nothing if import failed-importOrphan net t tx = do+importOrphan t tx = do go `catchError` ex where go = do maybetxids <-- newMempoolTx net tx t >>= \case+ newMempoolTx tx t >>= \case Just ths -> return (Just ths) Nothing -> return Nothing deleteOrphanTx (txHash tx)@@ -137,11 +137,10 @@ , MonadLogger m , MonadError ImportException m )- => Network- -> Tx+ => Tx -> UnixTime -> m (Maybe [TxHash]) -- ^ deleted transactions or nothing if import failed-newMempoolTx net tx w =+newMempoolTx tx w = getTxData (txHash tx) >>= \case Just x | not (txDataDeleted x) -> return Nothing@@ -153,7 +152,8 @@ mapM (getTxData . outPointHash . prevOutput) (txIn tx) if orp then do- $(logWarnS) "BlockStore" $ "Orphan tx: " <> txHashToHex (txHash tx)+ $(logWarnS) "BlockStore" $+ "Orphan tx: " <> txHashToHex (txHash tx) insertOrphanTx tx w throwError $ OrphanTx (txHashToHex (txHash tx)) else f@@ -165,10 +165,11 @@ let ds = map spenderHash (mapMaybe outputSpender us) if null ds then do- ths <- importTx net (MemRef w) w tx+ ths <- importTx (MemRef w) w tx return (Just ths) else g ds g ds = do+ net <- getNetwork rbf <- if getReplaceByFee net then and <$> mapM isrbf ds@@ -177,9 +178,10 @@ then r ds else n r ds = do- $(logWarnS) "BlockStore" $ "Replace by fee tx: " <> txHashToHex (txHash tx)- ths <- concat <$> forM ds (deleteTx net True)- dts <- importTx net (MemRef w) w tx+ $(logWarnS) "BlockStore" $+ "Replace by fee tx: " <> txHashToHex (txHash tx)+ ths <- concat <$> forM ds (deleteTx True)+ dts <- importTx (MemRef w) w tx return (Just (nub (ths <> dts))) n = do $(logWarnS) "BlockStore" $ "Conflicting tx: " <> txHashToHex (txHash tx)@@ -193,10 +195,9 @@ , MonadLogger m , MonadError ImportException m )- => Network- -> BlockHash+ => BlockHash -> m [TxHash]-revertBlock net bh = do+revertBlock bh = do bd <- getBestBlock >>= \case Nothing -> do@@ -217,7 +218,7 @@ txs <- mapM (fmap transactionData . getImportTx) (blockDataTxs bd) ths <- nub . concat <$>- mapM (deleteTx net False . txHash . snd) (reverse (sortTxs txs))+ mapM (deleteTx False . txHash . snd) (reverse (sortTxs txs)) setBest (prevBlock (blockDataHeader bd)) insertBlock bd {blockDataMainChain = False} return ths@@ -228,11 +229,10 @@ , MonadLogger m , MonadError ImportException m )- => Network- -> Block+ => Block -> BlockNode -> m [TxHash] -- ^ deleted transactions-importBlock net b n = do+importBlock b n = do mp <- filter (`elem` bths) . map blockTxHash <$> getMempool getBestBlock >>= \case Nothing@@ -250,6 +250,8 @@ blockHashToHex (headerHash (blockHeader b)) throwError $ PrevBlockNotBest (blockHashToHex (prevBlock (nodeHeader n)))+ net <- getNetwork+ let subsidy = computeSubsidy net (nodeHeight n) insertBlock BlockData { blockDataHeight = nodeHeight n@@ -259,8 +261,8 @@ , blockDataSize = fromIntegral (B.length (encode b)) , blockDataTxs = map txHash (blockTxns b) , blockDataWeight = fromIntegral w- , blockDataSubsidy = subsidy (nodeHeight n)- , blockDataFees = cb_out_val - subsidy (nodeHeight n)+ , blockDataSubsidy = subsidy+ , blockDataFees = cb_out_val - subsidy , blockDataOutputs = ts_out_val } bs <- getBlocksAtHeight (nodeHeight n)@@ -275,18 +277,16 @@ import_or_confirm mp x tx = if txHash tx `elem` mp then getTxData (txHash tx) >>= \case- Just td -> confirmTx net td (br x) tx >> return []+ Just td -> confirmTx td (br x) tx >> return [] Nothing -> do $(logErrorS) "BlockStore" $ "Cannot get data for mempool tx: " <> txHashToHex (txHash tx) throwError $ TxNotFound (txHashToHex (txHash tx)) else importTx- net (br x) (fromIntegral (blockTimestamp (nodeHeader n))) tx- subsidy = computeSubsidy net cb_out_val = sum (map outValue (txOut (head (blockTxns b)))) ts_out_val = sum (map (sum . map outValue . txOut) (tail (blockTxns b))) br pos = BlockRef {blockRefHeight = nodeHeight n, blockRefPos = pos}@@ -307,12 +307,11 @@ , MonadLogger m , MonadError ImportException m )- => Network- -> BlockRef+ => BlockRef -> Word64 -- ^ unix time -> Tx -> m [TxHash] -- ^ deleted transactions-importTx net br tt tx = do+importTx br tt tx = do when (length (nub (map prevOutput (txIn tx))) < length (txIn tx)) $ do $(logErrorS) "BlockStore" $ "Transaction spends same output twice: " <> txHashToHex (txHash tx)@@ -334,9 +333,9 @@ $(logErrorS) "BlockStore" $ "Insufficient funds for tx: " <> txHashToHex (txHash tx) throwError (InsufficientFunds (txHashToHex th))- zipWithM_ (spendOutput net br (txHash tx)) [0 ..] us+ zipWithM_ (spendOutput br (txHash tx)) [0 ..] us zipWithM_- (\i o -> newOutput net br (OutPoint (txHash tx) i) o)+ (\i o -> newOutput br (OutPoint (txHash tx) i) o) [0 ..] (txOut tx) rbf <- getrbf@@ -356,7 +355,7 @@ } let (d, _) = fromTransaction t insertTx d- updateAddressCounts net (txAddresses t) (+ 1)+ updateAddressCounts (txAddresses t) (+ 1) unless (confirmed br) $ insertIntoMempool (txHash tx) (memRefTime br) return ths where@@ -378,7 +377,7 @@ fromString (show (outPointIndex op)) throwError (NoUnspent (cs (show op))) Just Spender {spenderHash = s} -> do- ths <- deleteTx net True s+ ths <- deleteTx True s getUnspent op >>= \case Nothing -> do $(logErrorS) "BlockStore" $@@ -412,14 +411,15 @@ , inputWitness = w } mkin u ip w =- StoreInput- { inputPoint = prevOutput ip- , inputSequence = txInSequence ip- , inputSigScript = scriptInput ip- , inputPkScript = B.Short.fromShort (unspentScript u)- , inputAmount = unspentAmount u- , inputWitness = w- }+ let script = B.Short.fromShort (unspentScript u)+ in StoreInput+ { inputPoint = prevOutput ip+ , inputSequence = txInSequence ip+ , inputSigScript = scriptInput ip+ , inputPkScript = script+ , inputAmount = unspentAmount u+ , inputWitness = w+ } mkout o = StoreOutput { outputAmount = outValue o@@ -433,12 +433,11 @@ , MonadLogger m , MonadError ImportException m )- => Network- -> TxData+ => TxData -> BlockRef -> Tx -> m ()-confirmTx net t br tx = do+confirmTx t br tx = do forM_ (txDataPrevs t) $ \p -> case scriptToAddressBS (prevScript p) of Left _ -> return ()@@ -455,12 +454,14 @@ s <- getSpender (OutPoint (txHash tx) n) when (isNothing s) $ do deleteUnspent op+ net <- getNetwork insertUnspent Unspent { unspentBlock = br , unspentPoint = op , unspentAmount = outValue o , unspentScript = B.Short.toShort (scriptOutput o)+ , unspentAddress = scriptToStringAddr net (scriptOutput o) } case scriptToAddressBS (scriptOutput o) of Left _ -> return ()@@ -473,6 +474,7 @@ a BlockTx {blockTxBlock = br, blockTxHash = txHash tx} when (isNothing s) $ do+ net <- getNetwork deleteAddrUnspent a Unspent@@ -480,6 +482,8 @@ , unspentPoint = op , unspentAmount = outValue o , unspentScript = B.Short.toShort (scriptOutput o)+ , unspentAddress =+ scriptToStringAddr net (scriptOutput o) } insertAddrUnspent a@@ -488,8 +492,10 @@ , unspentPoint = op , unspentAmount = outValue o , unspentScript = B.Short.toShort (scriptOutput o)+ , unspentAddress =+ scriptToStringAddr net (scriptOutput o) }- reduceBalance net False False a (outValue o)+ reduceBalance False False a (outValue o) increaseBalance True False a (outValue o) insertTx t {txDataBlock = br} deleteFromMempool (txHash tx)@@ -511,11 +517,10 @@ , MonadLogger m , MonadError ImportException m )- => Network- -> Bool -- ^ only delete transaction if unconfirmed+ => Bool -- ^ only delete transaction if unconfirmed -> TxHash -> m [TxHash] -- ^ deleted transactions-deleteTx net mo h = do+deleteTx mo h = do getTxData h >>= \case Nothing -> do $(logErrorS) "BlockStore" $ "Cannot find tx to delete: " <> txHashToHex h@@ -532,14 +537,14 @@ where go t = do ss <- nub . map spenderHash . I.elems <$> getSpenders h- ths <- concat <$> mapM (deleteTx net True) ss+ ths <- concat <$> mapM (deleteTx True) ss forM_ (take (length (txOut (txData t))) [0 ..]) $ \n ->- delOutput net (OutPoint h n)+ delOutput (OutPoint h n) let ps = filter (/= nullOutPoint) (map prevOutput (txIn (txData t)))- mapM_ (unspendOutput net) ps+ mapM_ unspendOutput ps unless (confirmed (txDataBlock t)) $ deleteFromMempool h insertTx t {txDataDeleted = True}- updateAddressCounts net (txDataAddresses t) (subtract 1)+ updateAddressCounts (txDataAddresses t) (subtract 1) return $ nub (h : ths) insertDeletedMempoolTx ::@@ -556,7 +561,8 @@ forM (txIn tx) $ \TxIn {prevOutput = op} -> getImportTx (outPointHash op) >>= getTxOutput (outPointIndex op) rbf <- getrbf- let (d, _) =+ let d =+ fst $ fromTransaction Transaction { transactionBlock = MemRef w@@ -606,28 +612,29 @@ , StoreWrite m , MonadLogger m )- => Network- -> BlockRef+ => BlockRef -> OutPoint -> TxOut -> m ()-newOutput _ br op to = do- insertUnspent u+newOutput br op to = do+ net <- getNetwork+ insertUnspent (u net) case scriptToAddressBS (scriptOutput to) of Left _ -> return () Right a -> do- insertAddrUnspent a u+ insertAddrUnspent a (u net) insertAddrTx a BlockTx {blockTxHash = outPointHash op, blockTxBlock = br} increaseBalance (confirmed br) True a (outValue to) where- u =+ u net = Unspent { unspentBlock = br , unspentAmount = outValue to , unspentScript = B.Short.toShort (scriptOutput to) , unspentPoint = op+ , unspentAddress = scriptToStringAddr net (scriptOutput to) } delOutput ::@@ -636,10 +643,10 @@ , MonadLogger m , MonadError ImportException m )- => Network- -> OutPoint+ => OutPoint -> m ()-delOutput net op = do+delOutput op = do+ net <- getNetwork t <- getImportTx (outPointHash op) u <- getTxOutput (outPointIndex op) t deleteUnspent op@@ -653,6 +660,7 @@ , unspentBlock = transactionBlock t , unspentPoint = op , unspentAmount = outputAmount u+ , unspentAddress = scriptToStringAddr net (outputScript u) } deleteAddrTx a@@ -661,7 +669,6 @@ , blockTxBlock = transactionBlock t } reduceBalance- net (confirmed (transactionBlock t)) True a@@ -709,19 +716,17 @@ , MonadLogger m , MonadError ImportException m )- => Network- -> BlockRef+ => BlockRef -> TxHash -> Word32 -> Unspent -> m ()-spendOutput net br th ix u = do+spendOutput br th ix u = do insertSpender (unspentPoint u) Spender {spenderHash = th, spenderIndex = ix} case scriptToAddressBS (B.Short.fromShort (unspentScript u)) of Left _ -> return () Right a -> do reduceBalance- net (confirmed (unspentBlock u)) False a@@ -736,10 +741,9 @@ , MonadLogger m , MonadError ImportException m )- => Network- -> OutPoint+ => OutPoint -> m ()-unspendOutput _ op = do+unspendOutput op = do t <- getImportTx (outPointHash op) o <- getTxOutput (outPointIndex op) t s <-@@ -753,12 +757,14 @@ Just s -> return s x <- getImportTx (spenderHash s) deleteSpender op+ net <- getNetwork let u = Unspent { unspentAmount = outputAmount o , unspentBlock = transactionBlock t , unspentScript = B.Short.toShort (outputScript o) , unspentPoint = op+ , unspentAddress = scriptToStringAddr net (outputScript o) } insertUnspent u case scriptToAddressBS (outputScript o) of@@ -783,52 +789,51 @@ , MonadLogger m , MonadError ImportException m )- => Network- -> Bool -- ^ spend or delete confirmed output+ => Bool -- ^ spend or delete confirmed output -> Bool -- ^ reduce total received -> Address -> Word64 -> m ()-reduceBalance net c t a v =- getBalance a >>= \b ->- if nullBalance b- then do+reduceBalance c t a v = do+ net <- getNetwork+ b <- getBalance a+ if nullBalance b+ then do+ $(logErrorS) "BlockStore" $+ "Address balance not found: " <> addrText net a+ throwError (BalanceNotFound (addrText net a))+ else do+ when (v > amnt b) $ do $(logErrorS) "BlockStore" $- "Address balance not found: " <> addrText net a- throwError (BalanceNotFound (addrText net a))- else do- when (v > amnt b) $ do- $(logErrorS) "BlockStore" $- "Insufficient " <> conf <> " balance: " <>- addrText net a <>- " (needs: " <>- cs (show v) <>- ", has: " <>- cs (show (amnt b)) <>- ")"- throwError $- if c- then InsufficientBalance (addrText net a)- else InsufficientZeroBalance (addrText net a)- setBalance- b- { balanceAmount =- balanceAmount b -- if c- then v- else 0- , balanceZero =- balanceZero b -- if c- then 0- else v- , balanceUnspentCount = balanceUnspentCount b - 1- , balanceTotalReceived =- balanceTotalReceived b -- if t- then v- else 0- }+ "Insufficient " <> conf <> " balance: " <> addrText net a <>+ " (needs: " <>+ cs (show v) <>+ ", has: " <>+ cs (show (amnt b)) <>+ ")"+ throwError $+ if c+ then InsufficientBalance (addrText net a)+ else InsufficientZeroBalance (addrText net a)+ setBalance+ b+ { balanceAmount =+ balanceAmount b -+ if c+ then v+ else 0+ , balanceZero =+ balanceZero b -+ if c+ then 0+ else v+ , balanceUnspentCount = balanceUnspentCount b - 1+ , balanceTotalReceived =+ balanceTotalReceived b -+ if t+ then v+ else 0+ } where amnt = if c@@ -873,16 +878,17 @@ updateAddressCounts :: (StoreWrite m, StoreRead m, Monad m, MonadError ImportException m)- => Network- -> [Address]+ => [Address] -> (Word64 -> Word64) -> m ()-updateAddressCounts net as f =+updateAddressCounts as f = forM_ as $ \a -> do b <-- getBalance a >>= \b -> if nullBalance b- then throwError (BalanceNotFound (addrText net a))- else return b+ do net <- getNetwork+ b <- getBalance a+ if nullBalance b+ then throwError (BalanceNotFound (addrText net a))+ else return b setBalance b {balanceTxCount = f (balanceTxCount b)} txAddresses :: Transaction -> [Address]
src/Haskoin/Store/Manager.hs view
@@ -63,13 +63,15 @@ , storeConfInitPeers :: ![HostPort] -- ^ static set of peers to connect to , storeConfDiscover :: !Bool- -- ^ discover new peers?+ -- ^ discover new peers , storeConfDB :: !FilePath -- ^ RocksDB database path , storeConfNetwork :: !Network -- ^ network constants , storeConfCache :: !(Maybe String) -- ^ Redis cache configuration+ , storeConfInitialGap :: !Word32+ -- ^ gap on extended public key with no transactions , storeConfGap :: !Word32 -- ^ gap for extended public keys , storeConfCacheMin :: !Int@@ -88,16 +90,20 @@ let chain = inboxToMailbox chaininbox maybecacheconn <- case storeConfCache cfg of- Nothing -> return Nothing+ Nothing -> return Nothing Just redisurl -> Just <$> connectRedis redisurl- db <- connectRocksDB (storeConfGap cfg) (storeConfDB cfg)+ db <-+ connectRocksDB+ (storeConfNetwork cfg)+ (storeConfInitialGap cfg)+ (storeConfGap cfg)+ (storeConfDB cfg) case maybecacheconn of Nothing -> launch db Nothing chaininbox Just cacheconn -> do let cachecfg = CacheConfig { cacheConn = cacheconn- , cacheGap = storeConfGap cfg , cacheMin = storeConfCacheMin cfg , cacheChain = chain , cacheMax = storeConfMaxKeys cfg
src/Haskoin/Store/Web.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}@@ -13,8 +16,9 @@ import Conduit () import Control.Applicative ((<|>))-import Control.Monad (forever, guard, mzero, unless,- when, (<=<))+import Control.DeepSeq (NFData)+import Control.Monad (forever, guard, unless, when,+ (<=<)) import Control.Monad.Logger (MonadLogger, MonadLoggerIO, askLoggerIO, logInfoS, monadLoggerLog)@@ -43,6 +47,7 @@ import Data.Time.Clock.System (getSystemTime, systemSeconds) import Data.Word (Word32, Word64) import Database.RocksDB (Property (..), getProperty)+import GHC.Generics (Generic) import Haskoin (Address, Block (..), BlockHash (..), BlockHeader (..), BlockHeight,@@ -54,17 +59,16 @@ Version (..), decodeHex, eitherToMaybe, headerHash, hexToBlockHash, hexToTxHash,- sockToHostAddress, stringToAddr,- txHash, xPubImport)+ stringToAddr, txHash,+ xPubImport) import Haskoin.Node (Chain, Manager, OnlinePeer (..), chainGetBest, managerGetPeers, sendMessage) import Haskoin.Store.Cache (CacheT, withCache)-import Haskoin.Store.Common (BinSerial (..), BlockData (..),- BlockRef (..), BlockTx (..),- DeriveType (..), Event (..),- HealthCheck (..),- JsonSerial (..), Limit, Offset,+import Haskoin.Store.Common (BlockData (..), BlockRef (..),+ BlockTx (..), DeriveType (..),+ Event (..), HealthCheck (..),+ Limit, NetWrap (..), Offset, PeerInformation (..), PubExcept (..), StoreEvent (..), StoreInput (..), StoreRead (..),@@ -104,7 +108,7 @@ | UserError String | StringError String | BlockTooLarge- deriving Eq+ deriving (Eq, Ord, Serialize, Generic, NFData) instance Show Except where show ThingNotFound = "not found"@@ -123,28 +127,6 @@ instance ToJSON Except where toJSON e = object ["error" .= T.pack (show e)] -instance JsonSerial Except where- jsonSerial _ = toEncoding- jsonValue _ = toJSON--instance BinSerial Except where- binSerial _ ex =- case ex of- ThingNotFound -> putWord8 0- ServerError -> putWord8 1- BadRequest -> putWord8 2- UserError s -> putWord8 3 >> Serialize.put s- StringError s -> putWord8 4 >> Serialize.put s- BlockTooLarge -> putWord8 5- binDeserial _ =- getWord8 >>= \case- 0 -> return ThingNotFound- 1 -> return ServerError- 2 -> return BadRequest- 3 -> UserError <$> Serialize.get- 4 -> StringError <$> Serialize.get- _ -> mzero- data WebConfig = WebConfig { webPort :: !Int@@ -161,6 +143,7 @@ , maxLimitOffset :: !Word32 , maxLimitDefault :: !Word32 , maxLimitGap :: !Word32+ , maxLimitInitialGap :: !Word32 } deriving (Eq, Show) @@ -172,6 +155,7 @@ , maxLimitOffset = 50000 , maxLimitDefault = 2000 , maxLimitGap = 32+ , maxLimitInitialGap = 20 } data WebTimeouts =@@ -235,6 +219,9 @@ Just c -> withCache c cf instance MonadLoggerIO m => StoreRead (ReaderT WebConfig m) where+ getMaxGap = runInWebReader getMaxGap getMaxGap+ getInitialGap = runInWebReader getInitialGap getInitialGap+ getNetwork = runInWebReader getNetwork getNetwork getBestBlock = runInWebReader getBestBlock getBestBlock getBlocksAtHeight height = runInWebReader (getBlocksAtHeight height) (getBlocksAtHeight height)@@ -269,6 +256,7 @@ (xPubTxs xpub start offset limit) instance MonadLoggerIO m => StoreRead (WebT m) where+ getNetwork = lift getNetwork getBestBlock = lift getBestBlock getBlocksAtHeight = lift . getBlocksAtHeight getBlock = lift . getBlock@@ -290,6 +278,7 @@ lift (xPubUnspents xpub start offset limit) xPubTxs xpub start offset limit = lift (xPubTxs xpub start offset limit) getMaxGap = lift $ asks (maxLimitGap . webMaxLimits)+ getInitialGap = lift $ asks (maxLimitInitialGap . webMaxLimits) defHandler :: Monad m => Except -> WebT m () defHandler e = do@@ -304,23 +293,40 @@ protoSerial proto e maybeSerial ::- (Monad m, JsonSerial a, BinSerial a)+ (Monad m, ToJSON a, Serialize a) => Bool -- ^ binary -> Maybe a -> WebT m () maybeSerial _ Nothing = S.raise ThingNotFound maybeSerial proto (Just x) = do+ S.raw (serialAny proto x)++maybeSerialNet ::+ (Monad m, ToJSON (NetWrap a), Serialize a)+ => Bool+ -> Maybe a+ -> WebT m ()+maybeSerialNet _ Nothing = S.raise ThingNotFound+maybeSerialNet proto (Just x) = do net <- lift $ asks (storeNetwork . webStore)- S.raw (serialAny net proto x)+ S.raw (serialAnyNet net proto x) protoSerial ::- (Monad m, JsonSerial a, BinSerial a)+ (Monad m, ToJSON a, Serialize a) => Bool -> a -> WebT m () protoSerial proto x = do+ S.raw (serialAny proto x)++protoSerialNet ::+ (Monad m, ToJSON (NetWrap a), Serialize a)+ => Bool+ -> a+ -> WebT m ()+protoSerialNet proto x = do net <- lift $ asks (storeNetwork . webStore)- S.raw (serialAny net proto x)+ S.raw (serialAnyNet net proto x) scottyBestBlock :: (MonadLoggerIO m, MonadIO m) => Bool -> WebT m ()@@ -453,7 +459,7 @@ MyTxHash txid <- S.param "txid" proto <- setupBin res <- getTransaction txid- maybeSerial proto res+ maybeSerialNet proto res scottyRawTransaction :: MonadLoggerIO m => WebT m () scottyRawTransaction = do@@ -478,7 +484,7 @@ txids <- map (\(MyTxHash h) -> h) <$> S.param "txids" proto <- setupBin txs <- catMaybes <$> mapM getTransaction (nub txids)- protoSerial proto txs+ protoSerialNet proto txs scottyBlockTransactions :: MonadLoggerIO m => WebT m () scottyBlockTransactions = do@@ -491,7 +497,7 @@ refuseLargeBlock limits b let ths = blockDataTxs b txs <- catMaybes <$> mapM getTransaction ths- protoSerial proto txs+ protoSerialNet proto txs Nothing -> S.raise ThingNotFound scottyRawTransactions ::@@ -535,7 +541,7 @@ proto <- setupBin if full then do- getAddressTxsFull o l s a >>= protoSerial proto+ getAddressTxsFull o l s a >>= protoSerialNet proto else do getAddressTxsLimit o l s a >>= protoSerial proto @@ -548,7 +554,7 @@ l <- getLimit full proto <- setupBin if full- then getAddressesTxsFull l s as >>= protoSerial proto+ then getAddressesTxsFull l s as >>= protoSerialNet proto else getAddressesTxsLimit l s as >>= protoSerial proto scottyAddressUnspent :: MonadLoggerIO m => WebT m ()@@ -578,7 +584,7 @@ a <- parseAddress proto <- setupBin res <- getBalance a- protoSerial proto res+ protoSerialNet proto res scottyAddressesBalances :: MonadLoggerIO m => WebT m () scottyAddressesBalances = do@@ -586,7 +592,7 @@ as <- parseAddresses proto <- setupBin res <- getBalances as- protoSerial proto res+ protoSerialNet proto res scottyXpubBalances :: MonadLoggerIO m => WebT m () scottyXpubBalances = do@@ -594,7 +600,7 @@ xpub <- parseXpub proto <- setupBin res <- filter (not . nullBalance . xPubBal) <$> xPubBals xpub- protoSerial proto res+ protoSerialNet proto res scottyXpubTxs :: MonadLoggerIO m => Bool -> WebT m () scottyXpubTxs full = do@@ -607,7 +613,7 @@ if full then do txs' <- catMaybes <$> mapM (getTransaction . blockTxHash) txs- protoSerial proto txs'+ protoSerialNet proto txs' else protoSerial proto txs scottyXpubUnspents :: MonadLoggerIO m => WebT m ()@@ -669,7 +675,6 @@ scottyEvents :: MonadLoggerIO m => WebT m () scottyEvents = do- net <- lift $ asks (storeNetwork . webStore) pub <- lift $ asks (storePublisher . webStore) setHeaders proto <- setupBin@@ -688,7 +693,7 @@ Nothing -> return () Just e -> let bs =- serialAny net proto e <>+ serialAny proto e <> if proto then mempty else "\n"@@ -879,14 +884,17 @@ S.setHeader "Access-Control-Allow-Origin" "*" serialAny ::- (JsonSerial a, BinSerial a)- => Network- -> Bool -- ^ binary+ (ToJSON a, Serialize a)+ => Bool -- ^ binary -> a -> L.ByteString-serialAny net True = runPutLazy . binSerial net-serialAny net False = encodingToLazyByteString . jsonSerial net+serialAny True = runPutLazy . put+serialAny False = encodingToLazyByteString . toEncoding +serialAnyNet :: (ToJSON (NetWrap a), Serialize a) => Network -> Bool -> a -> L.ByteString+serialAnyNet _ True = runPutLazy . put+serialAnyNet net False = encodingToLazyByteString . toEncoding . NetWrap net+ setupBin :: Monad m => ActionT Except m Bool setupBin = let p = do@@ -993,7 +1001,7 @@ return PeerInformation { peerUserAgent = ua- , peerAddress = sockToHostAddress as+ , peerAddress = show as , peerVersion = vs , peerServices = sv , peerRelay = rl
test/Haskoin/Store/CommonSpec.hs view
@@ -1,61 +1,290 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Haskoin.Store.CommonSpec ( spec ) where -import Data.Serialize (decode, encode, runGet, runPut)-import Data.Text (Text)-import Haskoin (Address, Network, TxHash (TxHash), bch,- bchRegTest, bchTest, btc, btcRegTest,- btcTest, stringToAddr)-import Haskoin.Store.Common (BinSerial (..), DeriveType (..),- XPubSpec (..))-import Network.Haskoin.Test (arbitraryXPubKey)-import NQE ()-import Test.Hspec (Expectation, Spec, describe, it,- shouldBe)-import Test.Hspec.QuickCheck (prop)-import Test.QuickCheck (Gen, elements, forAll)+import Control.Monad (join)+import Data.Aeson (FromJSON, ToJSON)+import qualified Data.Aeson as A+import qualified Data.ByteString.Short as BSS+import Data.Serialize (Serialize (..), decode, encode)+import Data.String.Conversions (cs)+import Haskoin (Network, bch, bchRegTest, bchTest,+ btc, btcRegTest, btcTest)+import Haskoin.Store.Common (Balance (..), BlockData (..),+ BlockRef (..), BlockTx (..),+ DeriveType (..), Event (..),+ HealthCheck (..), NetWrap (..),+ PeerInformation (..), Prev (..),+ PubExcept (..), Spender (..),+ StoreInput (..), StoreOutput (..),+ Transaction (..), TxAfterHeight (..),+ TxData (..), TxId (..), Unspent (..),+ XPubBal (..), XPubSpec (..),+ XPubSummary (..), XPubUnspent (..))+import Network.Haskoin.Test (arbitraryAddress, arbitraryBlockHash,+ arbitraryBlockHeader,+ arbitraryOutPoint,+ arbitraryRejectCode, arbitraryScript,+ arbitraryTx, arbitraryTxHash,+ arbitraryXPubKey)+import NQE ()+import Test.Hspec (Expectation, Spec, describe, shouldBe)+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Arbitrary (..), Gen,+ arbitraryPrintableChar,+ arbitraryUnicodeChar, elements,+ forAll, listOf, listOf1, oneof) spec :: Spec spec = do- let net = btc- describe "Extended keys" $ do- prop "respect serialization identity identity" $- forAll arbitraryXPubSpec $ \(_, xpub) ->- Right xpub == (decode . encode) xpub- describe "Transaction hash serialisation" $ do- it "tx hash serialisation identity" $- let tx =- TxHash- "0666939fb16533c8e5ebaf6052bb8c90d27ee53fe6035bb763de5253e0b1cd44"- in testSerial net tx- describe "Address serialisation" $ do- it "address serialisation identity" $- let Just addr =- stringToAddr net "1DtDAYYTWRoiXvHRjARwVhjCUnNTk1XfXw"- in testSerial net addr- it "address list serialisation identity" $- let expected =- toAddrList- net- [ "1DtDAYYTWRoiXvHRjARwVhjCUnNTk1XfXw"- , "1GhnssnwRZwWKbHQXJRFpQfkfvE6hDG2KF"- ]- in testSerial net expected+ describe "Binary serialization" $ do+ prop "identity for derivation type" $ \x -> testSerial (x :: DeriveType)+ prop "identity for xpub spec" $ \x -> testSerial (x :: XPubSpec)+ prop "identity for block ref" $ \x -> testSerial (x :: BlockRef)+ prop "identity for block tx" $ \x -> testSerial (x :: BlockTx)+ prop "identity for balance" $ \x -> testSerial (x :: Balance)+ prop "identity for unspent" $ \x -> testSerial (x :: Unspent)+ prop "identity for block data" $ \x -> testSerial (x :: BlockData)+ prop "identity for input" $ \x -> testSerial (x :: StoreInput)+ prop "identity for spender" $ \x -> testSerial (x :: Spender)+ prop "identity for output" $ \x -> testSerial (x :: StoreOutput)+ prop "identity for previous output" $ \x -> testSerial (x :: Prev)+ prop "identity for tx data" $ \x -> testSerial (x :: TxData)+ prop "identity for transaction" $ \x -> testSerial (x :: Transaction)+ prop "identity for xpub balance" $ \x -> testSerial (x :: XPubBal)+ prop "identity for xpub unspent" $ \x -> testSerial (x :: XPubUnspent)+ prop "identity for xpub summary" $ \x -> testSerial (x :: XPubSummary)+ prop "identity for health check" $ \x -> testSerial (x :: HealthCheck)+ prop "identity for event" $ \x -> testSerial (x :: Event)+ prop "identity for tx after height" $ \x ->+ testSerial (x :: TxAfterHeight)+ prop "identity for txid" $ \x -> testSerial (x :: TxId)+ prop "identity for publish exception" $ \x ->+ testSerial (x :: PubExcept)+ prop "identity for peer info" $ \x -> testSerial (x :: PeerInformation)+ describe "JSON serialization" $ do+ prop "identity for balance" . forAll arbitraryNetData $ \(net, x) ->+ testNetJSON2 net (x :: Balance)+ prop "identity for block tx" $ \x -> testJSON (x :: BlockTx)+ prop "identity for block ref" $ \x -> testJSON (x :: BlockRef)+ prop "identity for unspent" $ \x -> testJSON (x :: Unspent)+ prop "identity for block data" $ \x -> testJSON (x :: BlockData)+ prop "identity for spender" $ \x -> testJSON (x :: Spender)+ prop "identity for transaction" . forAll arbitraryNetData $ \(net, x) ->+ testNetJSON1 net (x :: Transaction)+ prop "identity for xpub summary" $ \x -> testJSON (x :: XPubSummary)+ prop "identity for health check" $ \x -> testJSON (x :: HealthCheck)+ prop "identity for event" $ \x -> testJSON (x :: Event)+ prop "identity for txid" $ \x -> testJSON (x :: TxId)+ prop "identity for tx after height" $ \x ->+ testJSON (x :: TxAfterHeight)+ prop "identity for peer information" $ \x ->+ testJSON (x :: PeerInformation) -toAddrList :: Network -> [Text] -> [Address]-toAddrList net = map (\t -> let Just a = stringToAddr net t in a)+arbitraryNetData :: Arbitrary a => Gen (Network, a)+arbitraryNetData = do+ net <- arbitraryNetwork+ x <- arbitrary+ return (net, x) -testSerial :: (Eq a, Show a, BinSerial a) => Network -> a -> Expectation-testSerial net input =- let raw = runPut $ binSerial net input- deser = runGet (binDeserial net) raw- in deser `shouldBe` Right input+testJSON :: (Eq a, Show a, ToJSON a, FromJSON a) => a -> Expectation+testJSON input = (A.decode . A.encode) input `shouldBe` Just input -arbitraryXPubSpec :: Gen (Network, XPubSpec)-arbitraryXPubSpec = do- (_, k) <- arbitraryXPubKey- n <- elements [btc, bch, btcTest, bchTest, btcRegTest, bchRegTest]- t <- elements [DeriveNormal, DeriveP2SH, DeriveP2WPKH]- return (n, XPubSpec {xPubSpecKey = k, xPubDeriveType = t})+testNetJSON1 ::+ (Eq a, Show a, ToJSON (NetWrap a), FromJSON a) => Network -> a -> Expectation+testNetJSON1 net x =+ let encoded = A.encode (NetWrap net x)+ decoded = A.decode encoded+ in decoded `shouldBe` Just x++testNetJSON2 ::+ (Eq a, Show a, ToJSON (NetWrap a), FromJSON (Network -> Maybe a))+ => Network+ -> a+ -> Expectation+testNetJSON2 net x =+ let encoded = A.encode (NetWrap net x)+ decoder = A.decode encoded+ in join (($ net) <$> decoder) `shouldBe` Just x++testSerial :: (Eq a, Show a, Serialize a) => a -> Expectation+testSerial input = (decode . encode) input `shouldBe` Right input++instance Arbitrary TxAfterHeight where+ arbitrary = TxAfterHeight <$> arbitrary++instance Arbitrary DeriveType where+ arbitrary = elements [DeriveNormal, DeriveP2SH, DeriveP2WPKH]++instance Arbitrary XPubSpec where+ arbitrary = do+ (_, k) <- arbitraryXPubKey+ t <- arbitrary+ return XPubSpec {xPubSpecKey = k, xPubDeriveType = t}++instance Arbitrary XPubBal where+ arbitrary = XPubBal <$> arbitrary <*> arbitrary++instance Arbitrary XPubUnspent where+ arbitrary = XPubUnspent <$> arbitrary <*> arbitrary++instance Arbitrary Event where+ arbitrary =+ oneof [EventBlock <$> arbitraryBlockHash, EventTx <$> arbitraryTxHash]++instance Arbitrary XPubSummary where+ arbitrary =+ XPubSummary+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary++instance Arbitrary BlockRef where+ arbitrary = oneof [br, mr]+ where+ br = BlockRef <$> arbitrary <*> arbitrary+ mr = MemRef <$> arbitrary++instance Arbitrary BlockTx where+ arbitrary = do+ br <- arbitrary+ th <- arbitraryTxHash+ return BlockTx { blockTxBlock = br, blockTxHash = th}++arbitraryNetwork :: Gen Network+arbitraryNetwork = elements [bch, btc, bchTest, btcTest, bchRegTest, btcRegTest]++instance Arbitrary Balance where+ arbitrary =+ Balance+ <$> arbitraryAddress+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary++instance Arbitrary Unspent where+ arbitrary =+ Unspent+ <$> arbitrary+ <*> arbitraryOutPoint+ <*> arbitrary+ <*> (BSS.toShort . encode <$> arbitraryScript)+ <*> arbitrary++instance Arbitrary BlockData where+ arbitrary =+ BlockData+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitraryBlockHeader+ <*> arbitrary+ <*> arbitrary+ <*> listOf1 arbitraryTxHash+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary++instance Arbitrary StoreInput where+ arbitrary = oneof [cb, si]+ where+ cb = do+ st <- map encode <$> listOf arbitraryScript+ ws <- elements [Just st, Nothing]+ StoreCoinbase+ <$> arbitraryOutPoint+ <*> arbitrary+ <*> (encode <$> arbitraryScript)+ <*> pure ws+ si = do+ st <- map encode <$> listOf arbitraryScript+ ws <- elements [Just st, Nothing]+ StoreInput+ <$> arbitraryOutPoint+ <*> arbitrary+ <*> (encode <$> arbitraryScript)+ <*> (encode <$> arbitraryScript)+ <*> arbitrary+ <*> pure ws++instance Arbitrary Spender where+ arbitrary = Spender <$> arbitraryTxHash <*> arbitrary++instance Arbitrary Prev where+ arbitrary = Prev <$> (encode <$> arbitraryScript) <*> arbitrary++instance Arbitrary StoreOutput where+ arbitrary =+ StoreOutput+ <$> arbitrary+ <*> (encode <$> arbitraryScript)+ <*> arbitrary++instance Arbitrary TxData where+ arbitrary =+ TxData+ <$> arbitrary+ <*> (arbitraryTx =<< arbitraryNetwork)+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary++instance Arbitrary Transaction where+ arbitrary =+ Transaction+ <$> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary++instance Arbitrary PeerInformation where+ arbitrary = do+ PeerInformation+ <$> (cs <$> listOf arbitraryUnicodeChar)+ <*> listOf arbitraryPrintableChar+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary++instance Arbitrary HealthCheck where+ arbitrary = do+ bh <- arbitraryBlockHash+ hh <- arbitraryBlockHash+ let mb = elements [Nothing, Just bh]+ mh = elements [Nothing, Just hh]+ HealthCheck+ <$> mb+ <*> arbitrary+ <*> mh+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary+ <*> arbitrary++instance Arbitrary PubExcept where+ arbitrary =+ oneof+ [ pure PubNoPeers+ , PubReject <$> arbitraryRejectCode+ , pure PubTimeout+ , pure PubPeerDisconnected+ ]++instance Arbitrary TxId where+ arbitrary = TxId <$> arbitraryTxHash
test/Haskoin/StoreSpec.hs view
@@ -83,6 +83,7 @@ , storeConfNetwork = net , storeConfCache = Nothing , storeConfGap = gap+ , storeConfInitialGap = 20 , storeConfCacheMin = 100 , storeConfMaxKeys = 100 * 1000 * 1000 }