diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 } diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -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. diff --git a/src/Haskoin/Store.hs b/src/Haskoin/Store.hs --- a/src/Haskoin/Store.hs +++ b/src/Haskoin/Store.hs @@ -12,6 +12,7 @@ , XPubSummary (..) , XPubUnspent (..) , DeriveType (..) + , NetWrap (..) , UnixTime , Limit , Offset @@ -24,9 +25,6 @@ , transactionData , fromTransaction , toTransaction - - , BinSerial (..) - , JsonSerial (..) , blockAtOrBefore , confirmed diff --git a/src/Haskoin/Store/BlockStore.hs b/src/Haskoin/Store/BlockStore.hs --- a/src/Haskoin/Store/BlockStore.hs +++ b/src/Haskoin/Store/BlockStore.hs @@ -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) diff --git a/src/Haskoin/Store/Cache.hs b/src/Haskoin/Store/Cache.hs --- a/src/Haskoin/Store/Cache.hs +++ b/src/Haskoin/Store/Cache.hs @@ -1,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 diff --git a/src/Haskoin/Store/Common.hs b/src/Haskoin/Store/Common.hs --- a/src/Haskoin/Store/Common.hs +++ b/src/Haskoin/Store/Common.hs @@ -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)) diff --git a/src/Haskoin/Store/Database/Memory.hs b/src/Haskoin/Store/Database/Memory.hs --- a/src/Haskoin/Store/Database/Memory.hs +++ b/src/Haskoin/Store/Database/Memory.hs @@ -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 diff --git a/src/Haskoin/Store/Database/Reader.hs b/src/Haskoin/Store/Database/Reader.hs --- a/src/Haskoin/Store/Database/Reader.hs +++ b/src/Haskoin/Store/Database/Reader.hs @@ -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 diff --git a/src/Haskoin/Store/Database/Types.hs b/src/Haskoin/Store/Database/Types.hs --- a/src/Haskoin/Store/Database/Types.hs +++ b/src/Haskoin/Store/Database/Types.hs @@ -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) } diff --git a/src/Haskoin/Store/Database/Writer.hs b/src/Haskoin/Store/Database/Writer.hs --- a/src/Haskoin/Store/Database/Writer.hs +++ b/src/Haskoin/Store/Database/Writer.hs @@ -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 diff --git a/src/Haskoin/Store/Logic.hs b/src/Haskoin/Store/Logic.hs --- a/src/Haskoin/Store/Logic.hs +++ b/src/Haskoin/Store/Logic.hs @@ -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] diff --git a/src/Haskoin/Store/Manager.hs b/src/Haskoin/Store/Manager.hs --- a/src/Haskoin/Store/Manager.hs +++ b/src/Haskoin/Store/Manager.hs @@ -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 diff --git a/src/Haskoin/Store/Web.hs b/src/Haskoin/Store/Web.hs --- a/src/Haskoin/Store/Web.hs +++ b/src/Haskoin/Store/Web.hs @@ -1,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 diff --git a/test/Haskoin/Store/CommonSpec.hs b/test/Haskoin/Store/CommonSpec.hs --- a/test/Haskoin/Store/CommonSpec.hs +++ b/test/Haskoin/Store/CommonSpec.hs @@ -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 diff --git a/test/Haskoin/StoreSpec.hs b/test/Haskoin/StoreSpec.hs --- a/test/Haskoin/StoreSpec.hs +++ b/test/Haskoin/StoreSpec.hs @@ -83,6 +83,7 @@ , storeConfNetwork = net , storeConfCache = Nothing , storeConfGap = gap + , storeConfInitialGap = 20 , storeConfCacheMin = 100 , storeConfMaxKeys = 100 * 1000 * 1000 }