haskoin-store 1.6.5 → 1.7.0

raw patch · 11 files changed

+534/−178 lines, 11 filesdep ~haskoin-coredep ~haskoin-nodedep ~haskoin-store-dataPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: haskoin-core, haskoin-node, haskoin-store-data

API changes (from Hackage documentation)

Files

• haskoin-store.cabal +11/−10
• src/Haskoin/Store/BlockStore.hs +57/−49
• src/Haskoin/Store/Cache.hs +33/−27
• src/Haskoin/Store/Common.hs +13/−4
• src/Haskoin/Store/Database/Reader.hs +97/−20
• src/Haskoin/Store/Database/Types.hs +35/−7
• src/Haskoin/Store/Database/Writer.hs +60/−9
• src/Haskoin/Store/Logic.hs +30/−20
• src/Haskoin/Store/Web.hs +44/−15
• test/Haskoin/Store/LogicSpec.hs +93/−17
• test/Haskoin/Store/WebSpec.hs +61/−0

@@ -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 <https://github.com/jprupp/haskoin-store#readme> 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

@@ -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

@@ -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)

@@ -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) =>

@@ -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))

@@ -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)

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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