diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: haskoin-store -version: 1.6.5 +version: 1.7.0 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -52,9 +52,9 @@ , deepseq >=1.4.4.0 , hashable >=1.3.0.0 , hashtables >=1.2.4.2 - , haskoin-core >=1.5.1 - , haskoin-node >=2.2.0 - , haskoin-store-data ==1.6.3 + , haskoin-core >=1.6.0 + , haskoin-node >=2.3.0 + , haskoin-store-data ==1.7.0 , hedis >=0.16.1 , http-types >=0.12.3 , lens >=4.18.1 @@ -104,10 +104,10 @@ , filepath , hashable >=1.3.0.0 , hashtables >=1.2.4.2 - , haskoin-core >=1.5.1 - , haskoin-node >=2.2.0 + , haskoin-core >=1.6.0 + , haskoin-node >=2.3.0 , haskoin-store - , haskoin-store-data ==1.6.3 + , haskoin-store-data ==1.7.0 , hedis >=0.16.1 , http-types >=0.12.3 , lens >=4.18.1 @@ -144,6 +144,7 @@ Haskoin.Store.CacheSpec Haskoin.Store.LogicSpec Haskoin.Store.TestBlocks + Haskoin.Store.WebSpec Haskoin.StoreSpec Paths_haskoin_store hs-source-dirs: @@ -166,10 +167,10 @@ , fast-logger >=3.0 , hashable >=1.3.0.0 , hashtables >=1.2.4.2 - , haskoin-core >=1.5.1 - , haskoin-node >=2.2.0 + , haskoin-core >=1.6.0 + , haskoin-node >=2.3.0 , haskoin-store - , haskoin-store-data ==1.6.3 + , haskoin-store-data ==1.7.0 , hedis >=0.16.1 , hspec >=2.7.1 , http-types >=0.12.3 diff --git a/src/Haskoin/Store/BlockStore.hs b/src/Haskoin/Store/BlockStore.hs --- a/src/Haskoin/Store/BlockStore.hs +++ b/src/Haskoin/Store/BlockStore.hs @@ -276,12 +276,6 @@ p <- liftIO . getPeers =<< asks (.config.peerMgr) setGauge m.peers (length p) -setMempoolSize :: (MonadIO m) => BlockT m () -setMempoolSize = void $ runMaybeT $ do - m <- MaybeT (asks (.metrics)) - p <- lift getMempool - setGauge m.mempool (length p) - withBlockTiming :: (MonadIO m) => BlockT m (Either l r) -> BlockT m (Either l r) withBlockTiming go = do asks (.metrics) >>= \case @@ -343,10 +337,51 @@ Ctx -> ImportM a -> BlockT m (Either ImportException a) -runImport net ctx f = - ReaderT $ \r -> - liftIO . try $ runWriter net ctx r.config.db r.config.logger f +runImport net ctx f = fmap fst <$> runImportMempool net ctx f +-- | Like 'runImport', but also return how the import changed the mempool. +-- The mempool gauge is kept up to date from those changes instead of +-- counting the whole mempool on every clock tick. +runImportMempool :: + (MonadIO m) => + Network -> + Ctx -> + ImportM a -> + BlockT m (Either ImportException (a, MempoolChanges)) +runImportMempool net ctx f = do + r <- ReaderT $ \r -> + liftIO . try $ runWriterMempool net ctx r.config.db r.config.logger f + forM_ r $ \(_, c) -> asks (.metrics) >>= mapM_ (\m -> do + incrementGauge m.mempool (length c.added) + decrementGauge m.mempool (length c.removed)) + return r + +-- | Run an import and publish the transactions that it added to the +-- mempool or removed from it, then the new best block if there is one. +-- Transactions of the block are not published. +runImportNotify :: + (MonadIO m) => + Maybe Block -> + ImportM a -> + BlockT m (Either ImportException a) +runImportNotify block f = do + net <- getNetwork + ctx <- getCtx + runImportMempool net ctx f >>= \case + Left e -> return (Left e) + Right (x, c) -> do + l <- asks (.config.pub) + forM_ (filter notInBlock c.removed) $ \h -> + publish (StoreMempoolDelete h) l + forM_ (filter notInBlock c.added) $ \h -> + publish (StoreMempoolNew h) l + forM_ block $ \b -> + publish (StoreBestBlock (headerHash b.header)) l + return (Right x) + where + inBlock = maybe HashSet.empty (HashSet.fromList . map txHash . (.txs)) block + notInBlock = not . (`HashSet.member` inBlock) + runRocksDB :: ReaderT DatabaseReader m a -> BlockT m a runRocksDB f = ReaderT $ runReaderT f . (.config.db) @@ -372,6 +407,8 @@ runRocksDB . getBalance getMempool = runRocksDB getMempool + getMempoolPage = + runRocksDB . getMempoolPage instance (MonadUnliftIO m) => StoreReadExtra (BlockT m) where getMaxGap = @@ -535,10 +572,8 @@ <> blockText node Nothing <> " from peer " <> peer.label - net <- lift getNetwork - ctx <- lift getCtx - lift . notify (Just block) $ do - ret <- withBlockTiming $ runImport net ctx (importBlock block node) + lift $ do + ret <- withBlockTiming $ runImportNotify (Just block) (importBlock block node) case ret of Left e -> failure e Right _ -> success node @@ -794,42 +829,18 @@ when t $ fulfillOrphans block_read tx_hash return t -notify :: (MonadIO m) => Maybe Block -> BlockT m a -> BlockT m a -notify block go = do - old <- HashSet.union e . HashSet.fromList . map snd <$> getMempool - x <- go - new <- HashSet.union e . HashSet.fromList . map snd <$> getMempool - l <- asks (.config.pub) - forM_ (old `HashSet.difference` new) $ \h -> - publish (StoreMempoolDelete h) l - forM_ (new `HashSet.difference` old) $ \h -> - publish (StoreMempoolNew h) l - case block of - Just b -> publish (StoreBestBlock (headerHash b.header)) l - Nothing -> return () - return x - where - e = case block of - Just b -> HashSet.fromList (map txHash b.txs) - Nothing -> HashSet.empty - processMempool :: (MonadIO m) => BlockT m () processMempool = guardMempool $ do txs <- pendingTxs 2000 block_read <- ask - -- notify reads the whole mempool twice, so only when there is work to do - unless (null txs) $ notify Nothing (import_txs block_read txs) + unless (null txs) $ import_txs block_read txs where run_import block_read p = importMempoolTx block_read p.time p.tx import_txs block_read txs = - let r = mapM (run_import block_read) txs - in do - net <- getNetwork - ctx <- getCtx - runImport net ctx r >>= \case - Left e -> report_error e - Right _ -> return () + runImportNotify Nothing (mapM (run_import block_read) txs) >>= \case + Left e -> report_error e + Right _ -> return () report_error e = do logError $ "Error processing mempool: " <> cs (show e) @@ -840,17 +851,15 @@ guardMempool $ do days <- asks (.config.mempoolTimeout) when (days > 0) $ do - mempool <- reverse <$> getMempool time <- (floor . utcTimeToPOSIXSeconds) <$> liftIO getCurrentTime let thresh = time - (fromIntegral days * 24 * 60 * 60) - txs = take 1000 $ map snd $ takeWhile ((< thresh) . fst) mempool - net <- getNetwork - ctx <- getCtx - -- notify reads the whole mempool twice, so only when there is work to do - unless (null txs) . notify Nothing $ do + -- runs on every clock tick: read only the expired entries, oldest + -- first, from the index by time + txs <- map snd <$> runRocksDB (getMempoolBefore thresh 1000) + unless (null txs) $ do logInfo $ "Deleting " <> cs (show (length txs)) <> " old transactions from mempool" - runImport net ctx (mapM_ (deleteUnconfirmedTx False) txs) >>= \case + runImportNotify Nothing (mapM_ (deleteUnconfirmedTx False) txs) >>= \case Left e -> logError $ "Error pruning mempool: " <> cs (show e) @@ -1221,7 +1230,6 @@ setHeadersHeight setPendingTxs setPeersConnected - setMempoolSize trySyncing processMempool pruneOrphans 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 @@ -83,6 +83,7 @@ Ctx, DerivPathI (..), KeyIndex, + Network, OutPoint (..), Tx (..), TxHash, @@ -269,6 +270,7 @@ getBalance = lift . getBalance getUnspent = lift . getUnspent getMempool = lift getMempool + getMempoolPage = lift . getMempoolPage instance (StoreReadBase m) => StoreReadBase (CacheT m) where getCtx = lift getCtx @@ -281,6 +283,7 @@ getBalance = lift . getBalance getUnspent = lift . getUnspent getMempool = lift getMempool + getMempoolPage = lift . getMempoolPage instance (MonadUnliftIO m, StoreReadExtra m) => @@ -388,12 +391,13 @@ then do ops <- map snd <$> cacheGetXPubUnspents xpub limits uns <- catMaybes <$> lift (mapM getUnspent ops) + net <- lift getNetwork ctx <- lift getCtx let f u = either (const Nothing) (\a -> Just (a, u)) - (scriptToAddressBS ctx u.script) + (scriptToAddressBS net ctx u.script) xm = let j x = (x.balance.address, x) k = (> 0) . (.balance.utxo) @@ -1015,13 +1019,14 @@ [TxData] -> CacheX m () importMultiTxC txs = do + net <- lift getNetwork ctx <- lift getCtx logDebug $ "Processing " <> cs (show (length txs)) <> " txs" logDebug $ "Getting address information for " - <> cs (show (length (alladdrs ctx))) + <> cs (show (length (alladdrs net ctx))) <> " addresses" - addrmap <- getaddrmap ctx + addrmap <- getaddrmap net ctx let addrs = HashMap.keys addrmap logDebug $ "Getting balances for " @@ -1030,9 +1035,9 @@ balmap <- getbalances addrs logDebug $ "Getting unspent data for " - <> cs (show (length (allops ctx))) + <> cs (show (length (allops net ctx))) <> " outputs" - unspentmap <- getunspents ctx + unspentmap <- getunspents net ctx gap <- lift getMaxGap now <- round <$> liftIO getPOSIXTime :: (MonadIO m) => m Int let xpubs = allxpubsls addrmap @@ -1054,7 +1059,7 @@ let addrmap' = faddrmap (HashMap.keysSet xmap) addrmap logDebug "Starting Redis import pipeline" runRedis $ do - x <- redisImportMultiTx ctx addrmap' unspentmap txs + x <- redisImportMultiTx net ctx addrmap' unspentmap txs y <- redisUpdateBalances addrmap' balmap z <- redisTouchKeys now (HashMap.keys xmap) return $ x >> y >> z >> return () @@ -1062,18 +1067,18 @@ return $ getNewAddrs ctx gap xmap (HashMap.elems addrmap') cacheAddAddresses addrs' where - alladdrsls ctx = HashSet.toList (alladdrs ctx) + alladdrsls net ctx = HashSet.toList (alladdrs net ctx) faddrmap xmap = HashMap.filter (\a -> a.spec `elem` xmap) - getaddrmap ctx = + getaddrmap net ctx = HashMap.fromList . catMaybes - . zipWith (\a -> fmap (a,)) (alladdrsls ctx) - <$> cacheGetAddrsInfo (alladdrsls ctx) - getunspents ctx = + . zipWith (\a -> fmap (a,)) (alladdrsls net ctx) + <$> cacheGetAddrsInfo (alladdrsls net ctx) + getunspents net ctx = HashMap.fromList . catMaybes - . zipWith (\p -> fmap (p,)) (allops ctx) - <$> lift (mapM getUnspent (allops ctx)) + . zipWith (\p -> fmap (p,)) (allops net ctx) + <$> lift (mapM getUnspent (allops net ctx)) getbalances addrs = HashMap.fromList . zip addrs <$> mapM (lift . getDefaultBalance) addrs getxbals xpubs = do @@ -1081,27 +1086,28 @@ bs <- redisGetXPubBalances xpub return $ (,) xpub <$> bs return $ HashMap.filter (not . null) (HashMap.fromList bals) - allops ctx = + allops net ctx = map snd $ - concatMap (txInputs ctx) txs - <> concatMap (txOutputs ctx) txs - alladdrs ctx = + concatMap (txInputs net ctx) txs + <> concatMap (txOutputs net ctx) txs + alladdrs net ctx = HashSet.fromList $ map fst $ - concatMap (txInputs ctx) txs - <> concatMap (txOutputs ctx) txs + concatMap (txInputs net ctx) txs + <> concatMap (txOutputs net ctx) txs allxpubsls = HashSet.toList . allxpubs allxpubs = HashSet.fromList . map (.spec) . HashMap.elems redisImportMultiTx :: (Monad f, RedisCtx m f) => + Network -> Ctx -> HashMap Address AddressXPub -> HashMap OutPoint Unspent -> [TxData] -> m (f ()) -redisImportMultiTx ctx addrmap unspentmap tds = do +redisImportMultiTx net ctx addrmap unspentmap tds = do xs <- mapM importtxentries tds return $ sequence_ xs where @@ -1155,7 +1161,7 @@ in redisAddToMempool [tr] _ -> redisRemFromMempool [txHash td.tx] return $ a >> b >> return () - txaddrops td = txInputs ctx td <> txOutputs ctx td + txaddrops td = txInputs net ctx td <> txOutputs net ctx td redisUpdateBalances :: (Monad f, RedisCtx m f) => @@ -1466,17 +1472,17 @@ ths = map (txHash . snd) (sortTxs (map (.tx) tds)) in mapMaybe (`Map.lookup` txm) ths -txInputs :: Ctx -> TxData -> [(Address, OutPoint)] -txInputs ctx td = +txInputs :: Network -> Ctx -> TxData -> [(Address, OutPoint)] +txInputs net ctx td = let is = td.tx.inputs ps = I.toAscList td.prevs - as = map (scriptToAddressBS ctx . (.script) . snd) ps + as = map (scriptToAddressBS net ctx . (.script) . snd) ps f (Right a) i = Just (a, i.outpoint) f (Left _) _ = Nothing in catMaybes (zipWith f as is) -txOutputs :: Ctx -> TxData -> [(Address, OutPoint)] -txOutputs ctx td = +txOutputs :: Network -> Ctx -> TxData -> [(Address, OutPoint)] +txOutputs net ctx td = let ps = zipWith ( \i _ -> @@ -1487,7 +1493,7 @@ ) [0 ..] td.tx.outputs - as = map (scriptToAddressBS ctx . (.script)) td.tx.outputs + as = map (scriptToAddressBS net ctx . (.script)) td.tx.outputs f (Right a) p = Just (a, p) f (Left _) _ = Nothing in catMaybes (zipWith f as ps) 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 @@ -123,8 +123,15 @@ getSpender :: OutPoint -> m (Maybe Spender) getBalance :: Address -> m (Maybe Balance) getUnspent :: OutPoint -> m (Maybe Unspent) + -- | Whole mempool, newest first. getMempool :: m [(UnixTime, TxHash)] + -- | Page of the mempool, newest first, from the offset and limit of the + -- 'Limits'; its start is ignored. Stores that index the mempool by time + -- read only the entries of the page instead of the whole mempool. + getMempoolPage :: Limits -> m [(UnixTime, TxHash)] + getMempoolPage l = applyLimits l <$> getMempool + class (StoreReadBase m) => StoreReadExtra m where getAddressesTxs :: [Address] -> Limits -> m [TxRef] getAddressesUnspents :: [Address] -> Limits -> m [Unspent] @@ -201,14 +208,16 @@ getTransaction :: (StoreReadBase m) => TxHash -> m (Maybe Transaction) getTransaction h = do + net <- getNetwork ctx <- getCtx - fmap (toTransaction ctx) <$> getTxData h + fmap (toTransaction net ctx) <$> getTxData h getNumTransaction :: (StoreReadExtra m) => Word64 -> m [Transaction] -getNumTransaction i = - getCtx >>= \ctx -> - map (toTransaction ctx) <$> getNumTxData i +getNumTransaction i = do + net <- getNetwork + ctx <- getCtx + map (toTransaction net ctx) <$> getNumTxData i blockAtOrAfter :: (MonadIO m, StoreReadExtra m) => 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 @@ -25,6 +25,8 @@ heightCF, balanceCF, mempoolCF, + getMempoolBefore, + mempoolInsertOps, ) where @@ -40,7 +42,7 @@ import Data.List (sortOn) import Data.Maybe (fromMaybe, mapMaybe) import Data.Ord (Down (..)) -import Data.Serialize (encode) +import Data.Serialize (decode, encode) import Data.Text (Text) import Data.Text qualified as T import Data.Word (Word32) @@ -102,7 +104,7 @@ withMetrics go = asks (.metrics) >>= mapM_ go dataVersion :: Word32 -dataVersion = 19 +dataVersion = 20 withDB :: DatabaseReader -> DatabaseReaderT m a -> m a withDB = flip runReaderT @@ -219,20 +221,80 @@ retrieve db VersionKey >>= \case Just v | v == dataVersion -> return () + | v == 19 -> migrateMempoolIndex db | v == 18 -> migrateMempool db | otherwise -> error "Incorrect RocksDB database version" Nothing -> setInitRocksDB db -- | Version 18 kept the whole mempool as one list under 'MemKey'. Move each --- transaction to its own key in the mempool column family, in the same --- batch that sets the new version. +-- transaction to its own key in the mempool column family, and index it by +-- time, in the same batch that sets the new version. migrateMempool :: DB -> IO () migrateMempool db = do mempool <- fromMaybe [] <$> (retrieve db MemKey :: IO (Maybe [(UnixTime, TxHash)])) writeBatch db $ - [insertOpCF (mempoolCF db) (MemTxKey h) t | (t, h) <- mempool] + concat [mempoolInsertOps db h t | (t, h) <- mempool] <> [deleteOp MemKey, insertOp VersionKey dataVersion] +-- | Version 19 kept one key per mempool transaction, but no index by time, +-- so every page of the mempool had to read and sort all of it. Build the +-- index in the same batch that sets the new version. +migrateMempoolIndex :: DB -> IO () +migrateMempoolIndex db = do + mempool <- matchingAsListCF db (mempoolCF db) MemTxKeyS + writeBatch db $ + [insertOpCF (mempoolCF db) (MemTimeKey t h) () | (MemTxKey h, t) <- mempool] + <> [insertOp VersionKey dataVersion] + +-- | Operations that add a transaction to the mempool: its key and its entry +-- in the index by time. +mempoolInsertOps :: DB -> TxHash -> UnixTime -> [BatchOp] +mempoolInsertOps db h t = + [ insertOpCF (mempoolCF db) (MemTxKey h) t, + insertOpCF (mempoolCF db) (MemTimeKey t h) () + ] + +-- | Mempool from the index by time, newest first. The index sorts last in +-- the mempool column family, so seek past its prefix and walk backwards +-- until a key is no longer in it. +mempoolNewestC :: Iterator -> ConduitT i (UnixTime, TxHash) IO () +mempoolNewestC it = do + liftIO $ do + -- 0x0c is the first prefix after the 0x0b of 'MemTimeKey' + iterSeek it (BS.singleton 0x0c) + iterValid it >>= \case + True -> iterPrev it + False -> iterLast it + go + where + go = + liftIO (iterKey it) >>= \case + Just k | Right (MemTimeKey t h) <- decode k -> do + yield (t, h) + liftIO (iterPrev it) + go + _ -> return () + +-- | Mempool transactions that entered it before the given time, oldest +-- first, at most as many as given. Reads only those entries of the index. +getMempoolBefore :: + (MonadIO m) => + UnixTime -> + Int -> + DatabaseReaderT m [(UnixTime, TxHash)] +getMempoolBefore time n = do + db <- asks (.db) + liftIO . withIterCF db (mempoolCF db) $ \it -> + runConduit $ + matching it MemTimeKeyS + .| concatMapC entry + .| takeWhileC ((< time) . fst) + .| takeC n + .| sinkList + where + entry (MemTimeKey t h, ()) = Just (t, h) + entry (MemTimeKeyS, ()) = Nothing + setInitRocksDB :: DB -> IO () setInitRocksDB db = insert db VersionKey dataVersion @@ -280,13 +342,14 @@ unspentConduit :: (MonadIO m) => + Network -> Ctx -> Address -> Maybe Start -> Iterator -> ConduitT i Unspent (DatabaseReaderT m) () -unspentConduit ctx a s it = - x .| mapC (uncurry (toUnspent ctx)) .| concatC +unspentConduit net ctx a s it = + x .| mapC (uncurry (toUnspent net ctx)) .| concatC where x = case s of Nothing -> @@ -370,9 +433,10 @@ getUnspent p = do db <- asks (.db) + net <- asks (.net) ctx <- asks (.ctx) val <- liftIO (retrieveCF db (unspentCF db) (UnspentKey p)) - case fmap (valToUnspent ctx p) val of + case fmap (valToUnspent net ctx p) val of Nothing -> return Nothing Just u -> do withMetrics $ \s -> incrementCounter s.dataUnspentCount 1 @@ -383,14 +447,16 @@ withMetrics $ \s -> incrementCounter s.dataBalanceCount 1 fmap (valToBalance a) <$> liftIO (retrieveCF db (balanceCF db) (BalKey a)) - getMempool = do + getMempool = getMempoolPage def + + getMempoolPage limits = do db <- asks (.db) withMetrics $ \s -> incrementCounter s.dataMempoolCount 1 - sortOn Down . mapMaybe entry - <$> liftIO (matchingAsListCF db (mempoolCF db) MemTxKeyS) - where - entry (MemTxKey h, t) = Just (t, h) - entry (MemTxKeyS, _) = Nothing + liftIO . withIterCF db (mempoolCF db) $ \it -> + runConduit $ + mempoolNewestC it + .| applyLimitsC limits + .| sinkList getBestBlock = do withMetrics $ \s -> incrementCounter s.dataBestCount 1 @@ -425,21 +491,23 @@ getAddressesUnspents addrs limits = do db <- asks (.db) + net <- asks (.net) ctx <- asks (.ctx) withManyIters db (addrOutCF db) (length addrs) $ \its -> do - uns <- joinConduits (cs ctx its) limits + uns <- joinConduits (cs net ctx its) limits withMetrics $ \s -> incrementCounter s.dataUnspentCount (length uns) return uns where - cs ctx = zipWith (c ctx) addrs - c ctx a = unspentConduit ctx a limits.start + cs net ctx = zipWith (c net ctx) addrs + c net ctx a = unspentConduit net ctx a limits.start getAddressUnspents a limits = do db <- asks (.db) + net <- asks (.net) ctx <- asks (.ctx) us <- withIterCFStat db (addrOutCF db) $ \it -> runConduit $ - unspentConduit ctx a limits.start it + unspentConduit net ctx a limits.start it .| applyLimitsC limits .| sinkList withMetrics $ \s -> incrementCounter s.dataUnspentCount (length us) @@ -537,6 +605,15 @@ withMetrics $ \s -> incrementCounter s.dataXPubTxs (length txs) return txs - xPubTxCount xspec xbals = do + -- Count the merged streams instead of building the list of every + -- transaction of the xpub only to take its length. + xPubTxCount _xspec xbals = do withMetrics $ \s -> incrementCounter s.dataXPubTxCount 1 - fromIntegral . length <$> xPubTxs xspec xbals def + db <- asks (.db) + let as = + map (.address) $ + filter (not . nullBalance) $ + map (.balance) xbals + withManyIters db (addrTxCF db) (length as) $ \its -> + runConduit (joinDescStreams (zipWith (`addressConduit` Nothing) as its) .| lengthC) + >>= \n -> return (fromIntegral (n :: Int)) 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 @@ -17,6 +17,7 @@ HeightKey (..), MemKey (..), MemTxKey (..), + MemTimeKey (..), TxKey (..), decodeTxKey, UnspentKey (..), @@ -47,6 +48,7 @@ getBytes, getWord16be, getWord32be, + getWord64be, getWord8, putWord64be, putWord8, @@ -60,6 +62,7 @@ ( Address, BlockHash, BlockHeight, + Network, OutPoint (..), TxHash, eitherToMaybe, @@ -217,17 +220,17 @@ instance KeyValue UnspentKey UnspentVal -toUnspent :: Ctx -> AddrOutKey -> OutVal -> Maybe Unspent -toUnspent ctx (AddrOutKey _address block outpoint) (OutVal value script) = +toUnspent :: Network -> Ctx -> AddrOutKey -> OutVal -> Maybe Unspent +toUnspent net ctx (AddrOutKey _address block outpoint) (OutVal value script) = Just Unspent { block = block, value = value, script = script, outpoint = outpoint, - address = eitherToMaybe (scriptToAddressBS ctx script) + address = eitherToMaybe (scriptToAddressBS net ctx script) } -toUnspent _ _ _ = Nothing +toUnspent _ _ _ _ = Nothing -- | Mempool transaction database key. data MemKey @@ -268,6 +271,31 @@ instance KeyValue MemTxKey UnixTime +-- | Index of the mempool by the time each transaction entered it, in the +-- mempool column family next to 'MemTxKey'. Keys sort by time, then by +-- hash, as the pairs in 'getMempool' do, so a page of the mempool is read +-- with a short scan instead of loading and sorting every entry. +data MemTimeKey + = MemTimeKey !UnixTime !TxHash + | MemTimeKeyS + deriving (Show, Read, Eq, Ord, Generic, Hashable) + +instance Serialize MemTimeKey where + -- 0x0b · UnixTime (big endian) · TxHash + put (MemTimeKey t h) = do + put MemTimeKeyS + putWord64be t + put h + -- 0x0b + put MemTimeKeyS = putWord8 0x0b + get = do + guard . (== 0x0b) =<< getWord8 + MemTimeKey <$> getWord64be <*> get + +instance Key MemTimeKey + +instance KeyValue MemTimeKey () + -- | Block entry database key. newtype BlockKey = BlockKey BlockHash deriving (Show, Read, Eq, Ord, Generic, Hashable) @@ -391,8 +419,8 @@ unspentToVal :: Unspent -> (OutPoint, UnspentVal) unspentToVal Unspent {..} = (outpoint, UnspentVal {..}) -valToUnspent :: Ctx -> OutPoint -> UnspentVal -> Unspent -valToUnspent ctx outpoint UnspentVal {..} = +valToUnspent :: Network -> Ctx -> OutPoint -> UnspentVal -> Unspent +valToUnspent net ctx outpoint UnspentVal {..} = Unspent {..} where - address = eitherToMaybe (scriptToAddressBS ctx script) + address = eitherToMaybe (scriptToAddressBS net ctx script) 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 @@ -8,8 +8,16 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoFieldSelectors #-} -module Haskoin.Store.Database.Writer (WriterT, runWriter, writerLogger) where +module Haskoin.Store.Database.Writer + ( WriterT, + MempoolChanges (..), + runWriter, + runWriterMempool, + writerLogger, + ) +where +import Control.Monad (forM) import Control.Monad.Reader (ReaderT (..)) import Control.Monad.Reader qualified as R import Data.HashMap.Strict qualified as HashMap @@ -23,6 +31,7 @@ deleteOpCF, insertOp, insertOpCF, + retrieveCF, writeBatch, ) import Haskoin @@ -172,12 +181,34 @@ Logger -> WriterT m a -> m a -runWriter net ctx bdb@DatabaseReader {db} logger f = do +runWriter net ctx bdb logger f = + fst <$> runWriterMempool net ctx bdb logger f + +-- | Transactions that a batch added to the mempool or removed from it, +-- compared to what the database held before the batch was written. +data MempoolChanges = MempoolChanges + { added :: ![TxHash], + removed :: ![TxHash] + } + deriving (Eq, Show) + +-- | Like 'runWriter', but also say how the batch changed the mempool, so +-- that callers do not have to read the whole mempool before and after. +runWriterMempool :: + (MonadIO m) => + Network -> + Ctx -> + DatabaseReader -> + Logger -> + WriterT m a -> + m (a, MempoolChanges) +runWriterMempool net ctx bdb@DatabaseReader {db} logger f = do hm <- newMemory net ctx x <- R.runReaderT f Writer {reader = bdb, memory = hm, logger} ops <- hashMapOps db hm - liftIO $ writeBatch db ops - return x + (mops, changes) <- mempoolOps db hm.mempoolTable + liftIO $ writeBatch db (ops <> mops) + return (x, changes) hashMapOps :: (MonadIO m) => DB -> Memory -> m [BatchOp] hashMapOps db Memory {..} = @@ -190,7 +221,6 @@ balOps db balanceTable, addrTxOps db addressTable, addrOutOps db outputTable, - mempoolOps db mempoolTable, unspentOps db unspentTable ] @@ -243,11 +273,32 @@ (addrOutCF db) (AddrOutKey a b p) -mempoolOps :: (MonadIO m) => DB -> MempoolTable -> m [BatchOp] -mempoolOps db t = map (uncurry f) <$> liftIO (H.toList t) +-- | Operations for the mempool changes of a batch. Each changed entry is +-- compared to the database: its time is needed to update the index by +-- time, and the comparison says which transactions really entered or left +-- the mempool. +mempoolOps :: (MonadIO m) => DB -> MempoolTable -> m ([BatchOp], MempoolChanges) +mempoolOps db t = liftIO $ do + changes <- H.toList t + rows <- forM changes $ \(h, new) -> do + old <- retrieveCF db cf (MemTxKey h) + return (h, old, new) + return + ( concatMap ops rows, + MempoolChanges + { added = [h | (h, Nothing, Just _) <- rows], + removed = [h | (h, Just _, Nothing) <- rows] + } + ) where - f h (Just u) = insertOpCF (mempoolCF db) (MemTxKey h) u - f h Nothing = deleteOpCF (mempoolCF db) (MemTxKey h) + cf = mempoolCF db + ops (_, Nothing, Nothing) = [] + ops (h, Nothing, Just n) = mempoolInsertOps db h n + ops (h, Just o, Nothing) = + [deleteOpCF cf (MemTxKey h), deleteOpCF cf (MemTimeKey o h)] + ops (h, Just o, Just n) + | o == n = [] + | otherwise = deleteOpCF cf (MemTimeKey o h) : mempoolInsertOps db h n unspentOps :: (MonadIO m) => DB -> UnspentTable -> m [BatchOp] unspentOps db t = map (uncurry f) <$> liftIO (H.toList t) 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 @@ -354,8 +354,9 @@ replaceAddressTx :: TxData -> BlockRef -> ImportM () replaceAddressTx t new = do + net <- getNetwork ctx <- getCtx - forM_ (txDataAddresses ctx t) $ \a -> do + forM_ (txDataAddresses net ctx t) $ \a -> do deleteAddrTx a TxRef @@ -386,8 +387,9 @@ replace_unspent pk where replace_unspent pk = do + net <- getNetwork ctx <- getCtx - let ma = eitherToMaybe (scriptToAddressBS ctx pk) + let ma = eitherToMaybe (scriptToAddressBS net ctx pk) deleteUnspent op insertUnspent Unspent @@ -582,8 +584,9 @@ commitModTx :: Bool -> TxData -> ImportM () commitModTx add tx_data = do + net <- getNetwork ctx <- getCtx - mapM_ mod_addr_tx (txDataAddresses ctx td) + mapM_ mod_addr_tx (txDataAddresses net ctx td) mod_outputs mod_unspent insertTx td @@ -664,27 +667,28 @@ TxOut -> ImportM () modOutput add br op o = do + net <- getNetwork ctx <- getCtx - mod_unspent ctx - forM_ (ma ctx) $ \a -> do - mod_addr_unspent a (u ctx) + let ma = eitherToMaybe (scriptToAddressBS net ctx o.script) + mod_unspent ma + forM_ ma $ \a -> do + mod_addr_unspent a (u ma) modBalance (confirmed br) add a o.value modifyReceived a v where v | add = (+ o.value) | otherwise = subtract o.value - ma ctx = eitherToMaybe (scriptToAddressBS ctx o.script) - u ctx = + u ma = Unspent { script = o.script, block = br, outpoint = op, value = o.value, - address = ma ctx + address = ma } - mod_unspent ctx - | add = insertUnspent (u ctx) + mod_unspent ma + | add = insertUnspent (u ma) | otherwise = deleteUnspent op mod_addr_unspent | add = insertAddrUnspent @@ -734,8 +738,9 @@ deleteUnspent op insertSpender op (Spender th ix) let pk = u.script + net <- getNetwork ctx <- getCtx - forM_ (scriptToAddressBS ctx pk) $ \a -> do + forM_ (scriptToAddressBS net ctx pk) $ \a -> do decreaseBalance (confirmed u.block) a u.value deleteAddrUnspent a u @@ -744,6 +749,7 @@ unspendOutput :: OutPoint -> ImportM () unspendOutput op = do + net <- getNetwork ctx <- getCtx t <- getActiveTxData op.hash >>= \case @@ -753,7 +759,7 @@ fromMaybe (error ("Could not find output: " <> show op)) (getTxOut op.index t.tx) - m = eitherToMaybe (scriptToAddressBS ctx o.script) + m = eitherToMaybe (scriptToAddressBS net ctx o.script) u = Unspent { value = o.value, @@ -808,15 +814,19 @@ | add = (+ 1) | otherwise = subtract 1 -txOutAddrs :: Ctx -> [TxOut] -> [Address] -txOutAddrs ctx = nub' . rights . map (scriptToAddressBS ctx . (.script)) +txOutAddrs :: Network -> Ctx -> [TxOut] -> [Address] +txOutAddrs net ctx = + nub' . rights . map (scriptToAddressBS net ctx . (.script)) -txInAddrs :: Ctx -> [Prev] -> [Address] -txInAddrs ctx = nub' . rights . map (scriptToAddressBS ctx . (.script)) +txInAddrs :: Network -> Ctx -> [Prev] -> [Address] +txInAddrs net ctx = + nub' . rights . map (scriptToAddressBS net ctx . (.script)) -txDataAddresses :: Ctx -> TxData -> [Address] -txDataAddresses ctx t = - nub' $ txInAddrs ctx prevs <> txOutAddrs ctx outs +-- | Addresses that a transaction is indexed under. An output script counts +-- only when it has an address on the network. +txDataAddresses :: Network -> Ctx -> TxData -> [Address] +txDataAddresses net ctx t = + nub' $ txInAddrs net ctx prevs <> txOutAddrs net ctx outs where prevs = I.elems t.prevs outs = t.tx.outputs 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 @@ -20,6 +20,9 @@ Except (..), WebLimits (..), runWeb, + + -- * Request parsing + decodeTxBody, ) where @@ -459,6 +462,7 @@ getUnspent op = runInWebReader (getUnspent op) getBalance a = runInWebReader (getBalance a) getMempool = runInWebReader getMempool + getMempoolPage = runInWebReader . getMempoolPage instance (MonadUnliftIO m) => @@ -488,6 +492,7 @@ getUnspent = lift . getUnspent getBalance = lift . getBalance getMempool = lift getMempool + getMempoolPage = lift . getMempoolPage instance (MonadUnliftIO m) => StoreReadExtra (ActionT m) where getBalances = lift . getBalances @@ -655,7 +660,7 @@ toEncoding toJSON pathCompact - (PostTx <$> parseBody) + (PostTx <$> parseTxBody) scottyPostTx toEncoding toJSON @@ -1215,7 +1220,7 @@ WebLimits {..} <- askl (.config.limits) let wl' = WebLimits {maxItemCount = 0, ..} l = Limits (validateLimit wl' False limitM) (fromIntegral o) Nothing - map snd . applyLimits l <$> getMempool + map snd <$> getMempoolPage l webSocketEvents :: WebState -> Middleware webSocketEvents s = @@ -2365,8 +2370,13 @@ numtxid <- getNumTxId offset <- getBinfoOffset n <- getBinfoCount "limit" - mempool <- getMempool - let txids = map snd $ take n $ drop offset mempool + -- a limit of 0 would mean no limit to getMempoolPage + txids <- + if n <= 0 + then return [] + else + map snd + <$> getMempoolPage (Limits (fromIntegral n) (fromIntegral offset) Nothing) txs <- catMaybes <$> mapM getTransaction txids net <- askl (.config.store.net) setHeaders @@ -2527,6 +2537,7 @@ PeerInfo { userAgent = ver.userAgent.get, address = show op.address, + -- Signed, as the peer sent it. See 'PeerInfo'. version = ver.version, services = ver.services, relay = ver.relay @@ -2579,7 +2590,7 @@ n <- round <$> liftIO getPOSIXTime b <- fromIntegral . (.header.timestamp) <$> liftIO (chainGetBest ch) t <- - getMempool >>= \case + getMempoolPage (Limits 1 0 Nothing) >>= \case t : _ -> let x = fromIntegral $ fst t in return $ max x b @@ -2681,19 +2692,37 @@ where label = proxyLabel (Proxy :: Proxy a) -parseBody :: (MonadIO m, Serial a) => ActionT m a -parseBody = do +-- | Read the transaction that a request carries in its body. +parseTxBody :: (MonadUnliftIO m) => ActionT m Tx +parseTxBody = do + net <- askl (.config.store.net) b <- L.toStrict <$> S.body - case hex b <> bin b of + case decodeTxBody net b of Left _ -> raise $ UserError "Failed to parse request body" - Right x -> return x + Right tx -> return tx + +-- | Read a transaction from a request body. The body is the transaction in +-- hex or as raw bytes. White space in the hex is ignored. +-- +-- The body must hold one transaction and nothing else. Bytes after the +-- transaction are refused, as Bitcoin Core does for a raw transaction. +-- +-- The transaction must be in the format that peers of the network read. A +-- network without SegWit, such as Bitcoin Cash, has the format without +-- witness only. Its nodes would not read the SegWit format, so the store +-- does not take it either. +decodeTxBody :: Network -> C.ByteString -> Either String Tx +decodeTxBody net body = fromHex <> fromBytes body where - bin = runGetS deserialize - hex b = - let ns = C.filter (not . isSpace) b - in case parseBase16 ns of - Right b16 -> bin $ decodeBase16 b16 - Left e -> Left (cs e) + fromBytes = runGetS $ do + tx <- getNetworkTx net + done <- isEmpty + unless done $ fail "Trailing bytes after transaction" + return tx + fromHex = + case parseBase16 (C.filter (not . isSpace) body) of + Right b16 -> fromBytes (decodeBase16 b16) + Left e -> Left (cs e) parseOffset :: (MonadUnliftIO m) => ActionT m OffsetParam parseOffset = do diff --git a/test/Haskoin/Store/LogicSpec.hs b/test/Haskoin/Store/LogicSpec.hs --- a/test/Haskoin/Store/LogicSpec.hs +++ b/test/Haskoin/Store/LogicSpec.hs @@ -8,10 +8,11 @@ import Control.Monad (forM_, void) import Control.Monad.Reader (ask, liftIO, runReaderT) import Data.ByteString qualified as B -import Data.List (sort) +import Data.List (sort, sortOn) +import Data.Ord (Down (..)) import Data.Text qualified as T import Data.Word (Word32, Word64) -import Database.RocksDB.Query (insert, retrieve) +import Database.RocksDB.Query (insert, insertCF, matchingAsListCF, retrieve) import Haskoin ( Block (..), BlockHash, @@ -34,7 +35,7 @@ txHash, ) import Haskoin.Node (LogLevel (..), Logger (..)) -import Haskoin.Store.Common (StoreReadBase (..), getActiveTxData, getDefaultBalance) +import Haskoin.Store.Common (Limits (..), StoreReadBase (..), StoreWrite (..), getActiveTxData, getDefaultBalance) import Haskoin.Store.Data ( Balance (..), BlockData (..), @@ -43,9 +44,9 @@ TxData (..), Unspent (..), ) -import Haskoin.Store.Database.Reader (DatabaseReader (..), DatabaseReaderT, memoryReport, withDatabaseReader) -import Haskoin.Store.Database.Types (MemKey (..), VersionKey (..)) -import Haskoin.Store.Database.Writer (runWriter) +import Haskoin.Store.Database.Reader (DatabaseReader (..), DatabaseReaderT, getMempoolBefore, memoryReport, mempoolCF, withDatabaseReader) +import Haskoin.Store.Database.Types (MemKey (..), MemTimeKey (..), MemTxKey (..), VersionKey (..)) +import Haskoin.Store.Database.Writer (MempoolChanges (..), runWriter, runWriterMempool) import Haskoin.Store.Logic ( ImportException (..), ImportM, @@ -90,9 +91,63 @@ insert r.db MemKey old open $ ask >>= \r -> liftIO $ do reading r getMempool `shouldReturn` old + reading r (getMempoolPage (Limits 1 1 Nothing)) `shouldReturn` drop 1 old (retrieve r.db MemKey :: IO (Maybe [(Word64, TxHash)])) `shouldReturn` Nothing - retrieve r.db VersionKey `shouldReturn` Just (19 :: Word32) + retrieve r.db VersionKey `shouldReturn` Just (20 :: Word32) + describe "data version 19" $ + it "indexes the mempool by time when opened" $ + withSystemTempDirectory "haskoin-store-migrate-" $ \dir -> do + let open :: DatabaseReaderT IO () -> IO () + open = withDatabaseReader btcRegTest ctx 20 32 dir False Nothing Nothing Nothing Nothing + old = sortOn Down (zip [300, 100, 200] (hashes 3)) + open $ ask >>= \r -> liftIO $ do + insert r.db VersionKey (19 :: Word32) + forM_ old $ \(t, h) -> insertCF r.db (mempoolCF r.db) (MemTxKey h) t + (matchingAsListCF r.db (mempoolCF r.db) MemTimeKeyS :: IO [(MemTimeKey, ())]) + `shouldReturn` [] + open $ ask >>= \r -> liftIO $ do + reading r getMempool `shouldReturn` old + retrieve r.db VersionKey `shouldReturn` Just (20 :: Word32) + + describe "mempool index" $ do + let entries = zip [5, 3, 5, 1, 4, 3, 2] (hashes 7) + newest = sortOn Down entries + fill db = importing db (forM_ entries (\(t, h) -> addToMempool h t)) + it "pages the mempool newest first" $ + withDB btcRegTest ctx $ \db -> do + _ <- fill db + reading db getMempool `shouldReturn` newest + forM_ [(0, 0), (3, 0), (3, 2), (2, 5), (4, 7), (0, 3)] $ \(l, o) -> + reading db (getMempoolPage (Limits l o Nothing)) + `shouldReturn` take' l (drop (fromIntegral o) newest) + it "reads the oldest entries before a time" $ + withDB btcRegTest ctx $ \db -> do + _ <- fill db + let oldest = reverse newest + reading db (getMempoolBefore 4 10) `shouldReturn` takeWhile ((< 4) . fst) oldest + reading db (getMempoolBefore 4 2) `shouldReturn` take 2 oldest + reading db (getMempoolBefore 1 10) `shouldReturn` [] + it "reports and indexes what a batch changes" $ + withDB btcRegTest ctx $ \db -> do + let hs = hashes 3 + (h1, h2, h3) = (hs !! 0, hs !! 1, hs !! 2) + batch :: ImportM () -> IO MempoolChanges + batch = fmap snd . runWriterMempool db.net db.ctx db quietLogger + c <- batch (addToMempool h1 10 >> addToMempool h2 20) + (sort c.added, c.removed) `shouldBe` (sort [h1, h2], []) + -- a new time moves the entry in the index, and is no change + batch (addToMempool h1 30) `shouldReturn` MempoolChanges [] [] + reading db getMempool `shouldReturn` [(30, h1), (20, h2)] + -- removing what is not there, or adding and removing in one batch, + -- is no change either + batch (deleteFromMempool h3) `shouldReturn` MempoolChanges [] [] + batch (addToMempool h3 40 >> deleteFromMempool h3) `shouldReturn` MempoolChanges [] [] + batch (deleteFromMempool h2) `shouldReturn` MempoolChanges [] [h2] + reading db getMempool `shouldReturn` [(30, h1)] + (matchingAsListCF db.db (mempoolCF db.db) MemTimeKeyS :: IO [(MemTimeKey, ())]) + `shouldReturn` [(MemTimeKey 30 h1, ())] + describe "newMempoolTx" $ do it "imports a transaction and spends its input" $ withCoin btcRegTest ctx $ \db coin -> do @@ -314,7 +369,7 @@ describe "address balances" $ it "follow transactions through the mempool, a block and its reversal" $ withCoin btcRegTest ctx $ \db coin -> do - a <- either fail return (scriptToAddressBS ctx script) + a <- either fail return (scriptToAddressBS btcRegTest ctx script) let tx = spend [coin] [1000, 2000] -- confirmed, unconfirmed, outputs, transactions, received balance = do @@ -328,6 +383,17 @@ importing db (revertBlock (headerHash block.header)) `shouldReturn` Right () balance `shouldReturn` (0, 3000, 2, 2, 5000003000) + describe "a coin whose script has no address on the network" $ + it "is kept without an address" $ + withCoin btcRegTest ctx $ \db coin -> do + -- OP_HASH256, a push of 32 bytes, OP_EQUAL. Bitcoin Cash has an + -- address for this script. Bitcoin has none. + let hashLock = "\xaa\x20" <> B.replicate 32 0xbb <> "\x87" + tx = Tx 2 [TxIn coin "" maxBound] [TxOut 1000 hashLock] [] 0 + addTx db tx `shouldReturn` Right True + coinAddress <- fmap (.address) <$> reading db (getUnspent (out tx 0)) + coinAddress `shouldBe` Just Nothing + -- | Run with an empty database in a temporary directory. withDB :: Network -> Ctx -> (DatabaseReader -> IO a) -> IO a withDB net ctx go = @@ -344,15 +410,25 @@ go db (out (coinbaseTx 1) 0) importing :: DatabaseReader -> ImportM a -> IO (Either ImportException a) -importing db = try . runWriter db.net db.ctx db quiet - where - -- Build every message, so that log lines are tested too, but print none. - quiet = - Logger - { level = LevelDebug, - source = "", - push = void . evaluate . B.length . fromLogStr - } +importing db = try . runWriter db.net db.ctx db quietLogger + +-- | Build every message, so that log lines are tested too, but print none. +quietLogger :: Logger +quietLogger = + Logger + { level = LevelDebug, + source = "", + push = void . evaluate . B.length . fromLogStr + } + +-- | Distinct transaction hashes. +hashes :: Int -> [TxHash] +hashes n = [TxHash (sha256 (B.singleton (fromIntegral i))) | i <- [1 .. n]] + +-- | 'take' where a limit of 0 means no limit, as in 'Limits'. +take' :: Word32 -> [a] -> [a] +take' 0 = id +take' l = take (fromIntegral l) reading :: DatabaseReader -> DatabaseReaderT IO a -> IO a reading db f = runReaderT f db diff --git a/test/Haskoin/Store/WebSpec.hs b/test/Haskoin/Store/WebSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Store/WebSpec.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module Haskoin.Store.WebSpec (spec) where + +import Data.ByteString (ByteString) +import Data.Either (isLeft) +import Data.Maybe (fromJust) +import Data.Text.Encoding (decodeUtf8) +import Haskoin (Tx (..), bch, btc, decodeHex, txHash, txHashToHex) +import Haskoin.Store.Web (decodeTxBody) +import Test.Hspec + +-- | A transaction written by hand, in the format without witness. It has +-- version 1, one input that spends output 0 of transaction aa..aa with an +-- empty script, one output of 1000 satoshi to the script OP_TRUE, and lock +-- time 0. +plainTxHex :: ByteString +plainTxHex = + "01000000\ + \01aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ + \0000000000ffffffff\ + \01e8030000000000000151\ + \00000000" + +-- | The same transaction in the SegWit format. The marker and flag bytes +-- 00 01 follow the version, and the input has one witness item, the byte 01. +segwitTxHex :: ByteString +segwitTxHex = + "010000000001\ + \01aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\ + \0000000000ffffffff\ + \01e8030000000000000151\ + \010101\ + \00000000" + +spec :: Spec +spec = + describe "decodeTxBody" $ do + -- The id is the double SHA-256 of the bytes of plainTxHex, reversed. It + -- was computed outside this library. The witness is not part of the id, + -- so both formats of the transaction have this id. + let txid = "deca6f028918fa8d8c0efc66f2015cd5a2b5d42c8352a7e07468983f988900c9" + idOf = fmap (txHashToHex . txHash) + it "reads a transaction given as hex" $ + idOf (decodeTxBody btc plainTxHex) `shouldBe` Right txid + it "reads a transaction given as raw bytes" $ do + let bytes = fromJust (decodeHex (decodeUtf8 plainTxHex)) + idOf (decodeTxBody btc bytes) `shouldBe` Right txid + it "ignores white space around the hex" $ + idOf (decodeTxBody btc (" " <> plainTxHex <> "\r\n")) `shouldBe` Right txid + it "refuses bytes after the transaction" $ + decodeTxBody btc (plainTxHex <> "00") `shouldSatisfy` isLeft + it "reads the SegWit format on Bitcoin, with its witness" $ do + let tx = decodeTxBody btc segwitTxHex + idOf tx `shouldBe` Right txid + fmap (.witness) tx `shouldBe` Right [["\x01"]] + it "reads the format without witness on Bitcoin Cash" $ + idOf (decodeTxBody bch plainTxHex) `shouldBe` Right txid + it "refuses the SegWit format on Bitcoin Cash, which has no SegWit" $ + decodeTxBody bch segwitTxHex `shouldSatisfy` isLeft