haskoin-store 1.5.16 → 1.6.2

raw patch · 11 files changed

+319/−340 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, hedis, rocksdb-haskell-jprupp, rocksdb-query

API changes (from Hackage documentation)

Files

• haskoin-store.cabal +20/−20
• src/Haskoin/Store.hs +1/−0
• src/Haskoin/Store/BlockStore.hs +43/−43
• src/Haskoin/Store/Cache.hs +62/−45
• src/Haskoin/Store/Database/Reader.hs +88/−92
• src/Haskoin/Store/Database/Types.hs +50/−80
• src/Haskoin/Store/Database/Writer.hs +4/−13
• src/Haskoin/Store/Logic.hs +4/−4
• src/Haskoin/Store/Manager.hs +6/−5
• src/Haskoin/Store/Web.hs +37/−33
• test/Haskoin/StoreSpec.hs +4/−5

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.38.0.+-- This file has been generated from package.yaml by hpack version 0.39.6. -- -- see: https://github.com/sol/hpack  name:           haskoin-store-version:        1.5.16+version:        1.6.2 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,10 +52,10 @@     , deepseq >=1.4.4.0     , hashable >=1.3.0.0     , hashtables >=1.2.4.2-    , haskoin-core >=1.0.0-    , haskoin-node >=1.0.0-    , haskoin-store-data ==1.5.16-    , hedis >=0.12.13+    , haskoin-core >=1.3.0+    , haskoin-node >=1.4.3+    , haskoin-store-data ==1.6.0+    , hedis >=0.16.1     , http-types >=0.12.3     , lens >=4.18.1     , monad-control >=1.0.2.3@@ -64,8 +64,8 @@     , network >=3.1.1.1     , nqe >=0.6.5     , random >=1.1-    , rocksdb-haskell-jprupp >=2.1.3-    , rocksdb-query >=0.4.0+    , rocksdb-haskell-jprupp >=2.3.0+    , rocksdb-query >=0.6.0     , scotty >=0.22     , statsd-rupp >=0.4     , stm >=2.5.0.0@@ -105,11 +105,11 @@     , filepath     , hashable >=1.3.0.0     , hashtables >=1.2.4.2-    , haskoin-core >=1.0.0-    , haskoin-node >=1.0.0+    , haskoin-core >=1.3.0+    , haskoin-node >=1.4.3     , haskoin-store-    , haskoin-store-data ==1.5.16-    , hedis >=0.12.13+    , haskoin-store-data ==1.6.0+    , hedis >=0.16.1     , http-types >=0.12.3     , lens >=4.18.1     , monad-control >=1.0.2.3@@ -119,8 +119,8 @@     , nqe >=0.6.5     , optparse-applicative     , random >=1.1-    , rocksdb-haskell-jprupp >=2.1.3-    , rocksdb-query >=0.4.0+    , rocksdb-haskell-jprupp >=2.3.0+    , rocksdb-query >=0.6.0     , scotty >=0.22     , statsd-rupp >=0.4     , stm >=2.5.0.0@@ -164,11 +164,11 @@     , deepseq >=1.4.4.0     , hashable >=1.3.0.0     , hashtables >=1.2.4.2-    , haskoin-core >=1.0.0-    , haskoin-node >=1.0.0+    , haskoin-core >=1.3.0+    , haskoin-node >=1.4.3     , haskoin-store-    , haskoin-store-data ==1.5.16-    , hedis >=0.12.13+    , haskoin-store-data ==1.6.0+    , hedis >=0.16.1     , hspec >=2.7.1     , http-types >=0.12.3     , lens >=4.18.1@@ -178,8 +178,8 @@     , network >=3.1.1.1     , nqe >=0.6.5     , random >=1.1-    , rocksdb-haskell-jprupp >=2.1.3-    , rocksdb-query >=0.4.0+    , rocksdb-haskell-jprupp >=2.3.0+    , rocksdb-query >=0.6.0     , scotty >=0.22     , statsd-rupp >=0.4     , stm >=2.5.0.0

@@ -1,4 +1,5 @@ {-# LANGUAGE DuplicateRecordFields #-}+ module Haskoin.Store   ( Store (..),     StoreConfig (..),

@@ -126,7 +126,6 @@   ( Chain,     OnlinePeer (..),     Peer (..),-    PeerException (..),     PeerMgr,     chainBlockMain,     chainGetAncestor,@@ -269,7 +268,7 @@ setHeadersHeight :: (MonadIO m) => BlockT m () setHeadersHeight = void $ runMaybeT $ do   m <- MaybeT (asks (.metrics))-  n <- chainGetBest =<< asks (.config.chain)+  n <- liftIO . chainGetBest =<< asks (.config.chain)   setGauge m.headers (fromIntegral n.height)  setPendingTxs :: (MonadIO m) => BlockT m ()@@ -281,7 +280,7 @@ setPeersConnected :: (MonadIO m) => BlockT m () setPeersConnected = void $ runMaybeT $ do   m <- MaybeT (asks (.metrics))-  p <- getPeers =<< asks (.config.peerMgr)+  p <- liftIO . getPeers =<< asks (.config.peerMgr)   setGauge m.peers (length p)  setMempoolSize :: (MonadIO m) => BlockT m ()@@ -473,7 +472,7 @@       $(logErrorS) "BlockStore" "Block database uninitialized"       throwIO Uninitialized     Just bb -> do-      cb <- asks (.config.chain) >>= chainGetBest+      cb <- asks (.config.chain) >>= liftIO . chainGetBest       if headerHash cb.header == bb         then clearSyncingState >> return True         else return False@@ -494,7 +493,7 @@       $(logDebugS) "BlockStore" $         "Requesting mempool from peer: " <> p.label       atomically . modifyTVar m $ HashSet.insert p.label-      MMempool `sendMessage` p+      liftIO $ MMempool `sendMessage` p  processBlock ::   (MonadUnliftIO m, MonadLoggerIO m) =>@@ -508,9 +507,9 @@       $(logErrorS) "BlockStore" $         "Non-syncing peer "           <> peer.label-          <> " sent me a block: "+          <> " sent block "           <> blockHashToHex blockhash-      PeerMisbehaving "Sent unexpected block" `killPeer` peer+      killPeer peer       mzero   node <-     getBlockNode blockhash >>= \case@@ -519,14 +518,14 @@         $(logErrorS) "BlockStore" $           "Peer "             <> peer.label-            <> " sent unknown block: "+            <> " sent unknown block "             <> blockHashToHex blockhash-        PeerMisbehaving "Sent unknown block" `killPeer` peer+        killPeer peer         mzero   $(logDebugS) "BlockStore" $-    "Processing block: "+    "Processing block "       <> blockText node Nothing-      <> " from peer: "+      <> " from peer "       <> peer.label   net <- lift getNetwork   ctx <- lift getCtx@@ -557,7 +556,7 @@           <> peer.label           <> ": "           <> cs (show e)-      killPeer (PeerMisbehaving (show e)) peer+      killPeer peer  setSyncingBlocks ::   (MonadReader BlockStore m, MonadIO m) =>@@ -607,8 +606,9 @@   (MonadLoggerIO m, MonadReader BlockStore m) =>   BlockHash ->   m (Maybe BlockNode)-getBlockNode blockhash =-  chainGetBlock blockhash =<< asks (.config.chain)+getBlockNode blockhash = do+  ch <- asks (.config.chain)+  liftIO $ chainGetBlock ch blockhash  processNoBlocks ::   (MonadLoggerIO m) =>@@ -626,7 +626,7 @@         <> blockHashToHex h         <> " not found by peer: "         <> p.label-  killPeer (PeerMisbehaving "Did not find requested block(s)") p+  killPeer p  processTx :: (MonadLoggerIO m) => Peer -> Tx -> BlockT m () processTx p tx = guardMempool $ do@@ -832,22 +832,22 @@ pruneMempool :: (MonadLoggerIO m) => BlockT m () pruneMempool =   guardMempool . notify Nothing $ 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-    when (length txs > 0) $ do-      $(logInfoS) "BlockStore" $-        "Deleting " <> cs (show (length txs)) <> " old transactions from mempool"-      runImport net ctx (mapM_ (deleteUnconfirmedTx False) txs) >>= \case-        Left e ->-          $(logErrorS) "BlockStore" $-            "Error pruning mempool: " <> cs (show e)-        Right () -> return ()+    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+      when (length txs > 0) $ do+        $(logInfoS) "BlockStore" $+          "Deleting " <> cs (show (length txs)) <> " old transactions from mempool"+        runImport net ctx (mapM_ (deleteUnconfirmedTx False) txs) >>= \case+          Left e ->+            $(logErrorS) "BlockStore" $+              "Error pruning mempool: " <> cs (show e)+          Right () -> return ()  processTxs ::   (MonadLoggerIO m) =>@@ -908,7 +908,7 @@       let inv = if net.segWit then InvWitnessTx else InvTx           vec = map (InvVector inv . (.get)) xs           msg = MGetData (GetData vec)-      msg `sendMessage` p+      liftIO $ msg `sendMessage` p  touchPeer ::   ( MonadIO m,@@ -940,7 +940,7 @@         when (now `diffUTCTime` t > peer_time_out) $ do           $(logErrorS) "BlockStore" $             "Syncing peer timeout: " <> p.label-          killPeer PeerTimeout p+          killPeer p  revertToMainChain :: (MonadLoggerIO m) => BlockT m () revertToMainChain = do@@ -948,7 +948,7 @@   ch <- asks (.config.chain)   net <- getNetwork   ctx <- getCtx-  chainBlockMain h ch >>= \x -> unless x $ do+  liftIO (chainBlockMain ch h) >>= \x -> unless x $ do     $(logWarnS) "BlockStore" $       "Reverting best block: "         <> blockHashToHex h@@ -972,7 +972,7 @@         $(logErrorS) "BlockStore" "No best block set"         throwIO Uninitialized   ch <- asks (.config.chain)-  chainGetBlock bb ch >>= \case+  liftIO (chainGetBlock ch bb) >>= \case     Just x -> return x     Nothing -> do       $(logErrorS) "BlockStore" $@@ -992,7 +992,7 @@             throwIO Uninitialized       hs -> return $ last hs   ch <- asks (.config.chain)-  chainGetBlock bb ch >>= \case+  liftIO (chainGetBlock ch bb) >>= \case     Just x -> return x     Nothing -> do       $(logErrorS) "BlockStore" $@@ -1028,7 +1028,7 @@             <> " blocks from peer: "             <> p.label         addSyncingBlocks $ map (headerHash . (.header)) bns-        MGetData (GetData iv) `sendMessage` p+        liftIO $ MGetData (GetData iv) `sendMessage` p   where     getiv bns = do       w <- asks (.config.net.segWit)@@ -1036,12 +1036,12 @@           f = InvVector i . (.get) . headerHash . (.header)       return $ map f bns     getbh =-      chainGetBest =<< asks (.config.chain)+      liftIO . chainGetBest =<< asks (.config.chain)     sel bb bh = do       let sh = geth bb bh       t <- top sh bh       ch <- asks (.config.chain)-      ps <- chainGetParents (bb.height + 1) t ch+      ps <- liftIO $ chainGetParents ch (bb.height + 1) t       return $         if 500 > length ps           then ps <> [bh]@@ -1060,7 +1060,7 @@   m BlockNode findAncestor height target = do   ch <- asks (.config.chain)-  chainGetAncestor height target ch >>= \case+  liftIO (chainGetAncestor ch height target) >>= \case     Just ancestor -> return ancestor     Nothing -> do       let h = headerHash target.header@@ -1086,7 +1086,7 @@     reset_it box = do       atomically $ writeTVar box Nothing       $(logDebugS) "BlockStore" $ "Releasing peer: " <> p.label-      setFree p+      liftIO $ setFree p  trySetPeer :: (MonadLoggerIO m) => Peer -> BlockT m Bool trySetPeer p =@@ -1095,7 +1095,7 @@     Nothing -> set_it   where     set_it =-      setBusy p >>= \case+      liftIO (setBusy p) >>= \case         False -> return False         True -> do           $(logDebugS) "BlockStore" $@@ -1126,7 +1126,7 @@         False -> recurse ps         True -> syncMe     online_peer = do-      ops <- getPeers =<< asks (.config.peerMgr)+      ops <- liftIO . getPeers =<< asks (.config.peerMgr)       let ps = map (.mailbox) ops       recurse ps 

@@ -56,6 +56,7 @@ import Data.HashSet qualified as HashSet import Data.IntMap.Strict qualified as I import Data.List (sort)+import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict qualified as Map import Data.Maybe   ( catMaybes,@@ -629,9 +630,9 @@     xs <- fxs     return       [ (k, v)-        | (k', v') <- xs,-          let k = fromRight undefined $ decode k',-          let v = fromRight undefined $ decode v'+      | (k', v') <- xs,+        let k = fromRight undefined $ decode k',+        let v = fromRight undefined $ decode v'       ]  data CacheWriterMessage@@ -718,7 +719,10 @@               Redis.SetOpts                 { Redis.setSeconds = Just 300,                   Redis.setMilliseconds = Nothing,-                  Redis.setCondition = Just Redis.Nx+                  Redis.setUnixSeconds = Nothing,+                  Redis.setUnixMilliseconds = Nothing,+                  Redis.setCondition = Just Redis.Nx,+                  Redis.setKeepTTL = False                 }         Redis.setOpts l "locked" opts @@ -728,12 +732,15 @@         Redis.SetOpts           { Redis.setSeconds = Just 300,             Redis.setMilliseconds = Nothing,-            Redis.setCondition = Just Redis.Xx+            Redis.setUnixSeconds = Nothing,+            Redis.setUnixMilliseconds = Nothing,+            Redis.setCondition = Just Redis.Xx,+            Redis.setKeepTTL = False           }   Redis.setOpts l "locked" opts  unlockIt :: (MonadLoggerIO m) => ByteString -> CacheX m ()-unlockIt l = void $ runRedis (Redis.del [l])+unlockIt l = void . runRedis . Redis.del $ NonEmpty.singleton l  withLock ::   (MonadLoggerIO m, MonadUnliftIO m) =>@@ -861,10 +868,14 @@       Redis.SetOpts         { Redis.setSeconds = Just 600,           Redis.setMilliseconds = Nothing,-          Redis.setCondition = Just Redis.Nx+          Redis.setUnixSeconds = Nothing,+          Redis.setUnixMilliseconds = Nothing,+          Redis.setCondition = Just Redis.Nx,+          Redis.setKeepTTL = False         }     red = Redis.setOpts key "1" opts-    unset_index y = when y . void . runRedis $ Redis.del [key]+    unset_index y =+      when y . void . runRedis . Redis.del $ NonEmpty.singleton key     set_index = do       conn <- asks (.redis)       liftIO (Redis.runRedis conn red) <&> isRight@@ -877,7 +888,7 @@     Nothing -> return False     Just bb -> do       ch <- asks (.chain)-      cb <- chainGetBest ch+      cb <- liftIO $ chainGetBest ch       return $ cb.height > 0 && headerHash cb.header == bb  newBlockC ::@@ -908,18 +919,18 @@         Just best_block_hash -> get_block_node best_block_hash     get_block_node block_hash = do       ch <- asks (.chain)-      chainGetBlock block_hash ch+      liftIO $ chainGetBlock ch block_hash     get_blocks left_node right_node = do       ch <- asks (.chain)-      split_node <- chainGetSplitBlock left_node right_node ch+      split_node <- liftIO $ chainGetSplitBlock ch left_node right_node       let split_node_hash = headerHash split_node.header           right_node_hash = headerHash right_node.header       if split_node_hash == right_node_hash         then return []         else do           let fork_height = split_node.height + 1-          left_parents <- chainGetParents fork_height left_node ch-          right_parents <- chainGetParents fork_height right_node ch+          left_parents <- liftIO $ chainGetParents ch fork_height left_node+          right_parents <- liftIO $ chainGetParents ch fork_height right_node           let blocks = reverse left_parents <> right_parents <> pure right_node           return $ map (headerHash . (.header)) blocks @@ -1251,8 +1262,10 @@  redisRemFromMempool ::   (Applicative f, RedisCtx m f) => [TxHash] -> m (f Integer)-redisRemFromMempool [] = return (pure 0)-redisRemFromMempool xs = zrem mempoolSetKey $ map encode xs+redisRemFromMempool xs =+  case NonEmpty.nonEmpty xs of+    Nothing -> return (pure 0)+    Just xs' -> zrem mempoolSetKey $ NonEmpty.map encode xs'  redisSetAddrInfo ::   (Functor f, RedisCtx m f) => Address -> AddressXPub -> m (f ())@@ -1287,13 +1300,13 @@   where     go addrs = do       addrcount <--        case addrs of-          [] -> return (pure 0)-          _ -> Redis.del (map ((addrPfx <>) . encode) addrs)-      txsetcount <- Redis.del [txSetPfx <> encode xpub]-      utxocount <- Redis.del [utxoPfx <> encode xpub]-      balcount <- Redis.del [balancesPfx <> encode xpub]-      x <- Redis.zrem maxKey [encode xpub]+        case NonEmpty.nonEmpty addrs of+          Nothing -> return (pure 0)+          Just addrs' -> Redis.del $ NonEmpty.map ((addrPfx <>) . encode) addrs'+      txsetcount <- Redis.del $ NonEmpty.singleton (txSetPfx <> encode xpub)+      utxocount <- Redis.del $ NonEmpty.singleton (utxoPfx <> encode xpub)+      balcount <- Redis.del $ NonEmpty.singleton (balancesPfx <> encode xpub)+      x <- Redis.zrem maxKey $ NonEmpty.singleton (encode xpub)       return $ do         _ <- x         addrs' <- addrcount@@ -1311,8 +1324,10 @@  redisRemXPubTxs ::   (Applicative f, RedisCtx m f) => XPubSpec -> [TxHash] -> m (f Integer)-redisRemXPubTxs _ [] = return (pure 0)-redisRemXPubTxs xpub txhs = zrem (txSetPfx <> encode xpub) (map encode txhs)+redisRemXPubTxs xpub txhs =+  case NonEmpty.nonEmpty txhs of+    Nothing -> return (pure 0)+    Just txhs' -> zrem (txSetPfx <> encode xpub) (NonEmpty.map encode txhs')  redisAddXPubUnspents ::   (Applicative f, RedisCtx m f) =>@@ -1330,23 +1345,26 @@ redisRemXPubUnspents _ [] =   return (pure 0) redisRemXPubUnspents xpub ops =-  zrem (utxoPfx <> encode xpub) (map encode ops)+  case NonEmpty.nonEmpty ops of+    Nothing -> return (pure 0)+    Just ops' -> zrem (utxoPfx <> encode xpub) (NonEmpty.map encode ops')  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-  ys <- forM bals $ \b ->-    redisSetAddrInfo-      b.balance.address-      AddressXPub-        { spec = xpub,-          path = b.path-        }-  return $ sequence_ xs >> sequence_ ys-  where-    entries = map (\b -> (encode b.path, encode b.balance)) bals+redisAddXPubBalances xpub bals =+  case NonEmpty.nonEmpty bals of+    Nothing -> return (pure ())+    Just bals' -> do+      let bs = NonEmpty.map (\b -> (encode b.path, encode b.balance)) bals'+      Redis.hset (balancesPfx <> encode xpub) bs+      ys <- forM bals' $ \b ->+        redisSetAddrInfo+          b.balance.address+          AddressXPub+            { spec = xpub,+              path = b.path+            }+      return $ sequence_ ys  redisSetHead :: (RedisCtx m f) => BlockHash -> m (f Redis.Status) redisSetHead bh = Redis.set bestBlockKey (encode bh)@@ -1375,13 +1393,13 @@   | otherwise =       zipWith f addrs list   where-    haschange = any ((== 1) . head . (.path)) xbals+    haschange = any ((== 1) . (!! 0) . (.path)) xbals     f a p = (a, AddressXPub {spec = xpub, path = p})-    dchain = head addrinfo.path-    fbals = filter ((== dchain) . head . (.path)) xbals-    maxidx = maximum (map (head . tail . (.path)) fbals)+    dchain = addrinfo.path !! 0+    fbals = filter ((== dchain) . (!! 0) . (.path)) xbals+    maxidx = maximum (map ((!! 1) . (.path)) fbals)     xpub = addrinfo.spec-    aidx = (head . tail) addrinfo.path+    aidx = addrinfo.path !! 1     ixs =       if gap > maxidx - aidx         then [maxidx + 1 .. aidx + gap]@@ -1440,8 +1458,7 @@     f t s = ((scoreBlockRef s).timestamp, t)  xpubText ::-  ( StoreReadBase m-  ) =>+  (StoreReadBase m) =>   XPubSpec ->   CacheX m Text xpubText xpub = do

@@ -27,16 +27,8 @@ where  import Conduit-  ( ConduitT,-    dropWhileC,-    lift,-    mapC,-    runConduit,-    sinkList,-    (.|),-  )-import Control.Monad.Except (runExceptT, throwError)-import Control.Monad.Reader (MonadReader, ReaderT, asks, runReaderT)+import Control.Monad (forM_)+import Control.Monad.Reader import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Data.Bits ((.&.)) import Data.ByteString qualified as BS@@ -47,28 +39,14 @@ import Data.Ord (Down (..)) import Data.Serialize (encode) import Data.Word (Word32)-import Database.RocksDB-  ( ColumnFamily,-    Config (..),-    DB (..),-    Iterator,-    withDBCF,-    withIterCF,-  )+import Database.RocksDB hiding (withDB) import Database.RocksDB.Query-  ( insert,-    matching,-    matchingAsListCF,-    matchingSkip,-    retrieve,-    retrieveCF,-  ) import Haskoin import Haskoin.Store.Common import Haskoin.Store.Data import Haskoin.Store.Database.Types import System.Metrics.StatsD-import UnliftIO (MonadIO, MonadUnliftIO, bracket_, liftIO)+import UnliftIO  type DatabaseReaderT = ReaderT DatabaseReader @@ -96,7 +74,7 @@     dataIters :: !StatGauge   } -createDataMetrics :: (MonadIO m) => Stats -> m DataMetrics+createDataMetrics :: Stats -> IO DataMetrics createDataMetrics s = do   dataBestCount <- newStatCounter s "db.best_block" n   dataBlockCount <- newStatCounter s "db.blocks" n@@ -134,19 +112,20 @@   Maybe DataMetrics ->   DatabaseReaderT m a ->   m a-withDatabaseReader net ctx igap gap dir bloom stats f =-  withDBCF dir cfg (columnFamilyConfig bloom) $ \db -> do-    let bdb =-          DatabaseReader-            { db = db,-              maxGap = gap,-              net = net,-              initGap = igap,-              metrics = stats,-              ctx = ctx-            }-    initRocksDB bdb-    runReaderT f bdb+withDatabaseReader net ctx igap gap dir bloom stats m =+  withRunInIO $ \run ->+    withDBCF dir cfg (columnFamilyConfig bloom) $ \db -> do+      let bdb =+            DatabaseReader+              { db = db,+                maxGap = gap,+                net = net,+                initGap = igap,+                metrics = stats,+                ctx = ctx+              }+      initRocksDB bdb+      run $ runReaderT m bdb   where     cfg = def {createIfMissing = True} @@ -163,7 +142,7 @@   ]  addrTxCF :: DB -> ColumnFamily-addrTxCF = head . columnFamilies+addrTxCF db = columnFamilies db !! 0  addrOutCF :: DB -> ColumnFamily addrOutCF db = columnFamilies db !! 1@@ -183,81 +162,93 @@ balanceCF :: DB -> ColumnFamily balanceCF db = columnFamilies db !! 7 -initRocksDB :: (MonadIO m) => DatabaseReader -> m ()-initRocksDB DatabaseReader {db = db} = do-  e <--    runExceptT $-      retrieve db VersionKey >>= \case-        Just v-          | v == dataVersion -> return ()-          | otherwise -> throwError "Incorrect RocksDB database version"-        Nothing -> setInitRocksDB db-  case e of-    Left s -> error s-    Right () -> return ()+initRocksDB :: DatabaseReader -> IO ()+initRocksDB DatabaseReader {db = db} =+  retrieve db VersionKey >>= \case+    Just v+      | v == dataVersion -> return ()+      | otherwise -> error "Incorrect RocksDB database version"+    Nothing -> setInitRocksDB db -setInitRocksDB :: (MonadIO m) => DB -> m ()+setInitRocksDB :: DB -> IO () setInitRocksDB db = insert db VersionKey dataVersion  addressConduit ::-  (MonadUnliftIO m) =>+  (MonadIO m) =>   Address ->   Maybe Start ->   Iterator ->   ConduitT i TxRef (DatabaseReaderT m) ()-addressConduit a s it =-  x .| mapC (uncurry f)+addressConduit a s it = do+  pipe .| mapC (uncurry f)   where     f (AddrTxKey _ t) () = t     f _ _ = undefined-    x = case s of+    pipe = case s of       Nothing ->-        matching it (AddrTxKeyA a)+        readerC $ \_ ->+          transPipe liftIO $+            matching it (AddrTxKeyA a)       Just (AtBlock bh) ->-        matchingSkip-          it-          (AddrTxKeyA a)-          (AddrTxKeyB a (BlockRef bh maxBound))+        readerC $ \_ ->+          transPipe liftIO $+            matchingSkip+              it+              (AddrTxKeyA a)+              (AddrTxKeyB a (BlockRef bh maxBound))       Just (AtTx txh) ->         lift (getTxData txh) >>= \case           Just TxData {block = b@BlockRef {}} ->-            matchingSkip it (AddrTxKeyA a) (AddrTxKeyB a b)+            readerC $ \_ ->+              transPipe liftIO $+                matchingSkip+                  it+                  (AddrTxKeyA a)+                  (AddrTxKeyB a b)           Just TxData {block = MemRef {}} ->             let cond (AddrTxKey _ (TxRef MemRef {} th)) = th /= txh                 cond (AddrTxKey _ (TxRef BlockRef {} _)) = False                 cond _ = undefined-             in matching it (AddrTxKeyA a)-                  .| (dropWhileC (cond . fst) >> mapC id)+             in readerC $ \_ ->+                  transPipe liftIO $+                    matching it (AddrTxKeyA a)+                      .| (dropWhileC (cond . fst) >> mapC id)           Nothing -> return ()  unspentConduit ::-  (MonadUnliftIO m) =>+  (MonadIO m) =>   Ctx ->   Address ->   Maybe Start ->   Iterator ->   ConduitT i Unspent (DatabaseReaderT m) () unspentConduit ctx a s it =-  x .| mapC (uncurry (toUnspent ctx))+  x .| mapC (uncurry (toUnspent ctx)) .| concatC   where     x = case s of       Nothing ->-        matching it (AddrOutKeyA a)+        readerC $ \_ -> transPipe liftIO $ matching it (AddrOutKeyA a)       Just (AtBlock h) ->-        matchingSkip-          it-          (AddrOutKeyA a)-          (AddrOutKeyB a (BlockRef h maxBound))+        readerC $ \_ ->+          transPipe liftIO $+            matchingSkip+              it+              (AddrOutKeyA a)+              (AddrOutKeyB a (BlockRef h maxBound))       Just (AtTx txh) ->         lift (getTxData txh) >>= \case           Just TxData {block = b@BlockRef {}} ->-            matchingSkip it (AddrOutKeyA a) (AddrOutKeyB a b)+            readerC $ \_ ->+              transPipe liftIO $+                matchingSkip it (AddrOutKeyA a) (AddrOutKeyB a b)           Just TxData {block = MemRef {}} ->             let cond (AddrOutKey _ MemRef {} p) = p.hash /= txh                 cond (AddrOutKey _ BlockRef {} _) = False                 cond _ = undefined-             in matching it (AddrOutKeyA a)-                  .| (dropWhileC (cond . fst) >> mapC id)+             in readerC $ \_ ->+                  transPipe liftIO $+                    matching it (AddrOutKeyA a)+                      .| (dropWhileC (cond . fst) >> mapC id)           Nothing -> return ()  withIterCFStat ::@@ -266,10 +257,16 @@   ColumnFamily ->   (Iterator -> DatabaseReaderT m a) ->   DatabaseReaderT m a-withIterCFStat db cf = bracket_ open close . withIterCF db cf+withIterCFStat db cf f = do+  m <- asks (.metrics)+  bracket_ (open m) (close m) go   where-    open = asks (.metrics) >>= mapM_ (\m -> incrementGauge m.dataIters 1)-    close = asks (.metrics) >>= mapM_ (\m -> decrementGauge m.dataIters 1)+    open (Just m) = incrementGauge m.dataIters 1+    open Nothing = return ()+    close (Just m) = decrementGauge m.dataIters 1+    close Nothing = return ()+    go = withRunInIO $ \run ->+      withIterCF db cf $ \it -> run (f it)  withManyIters ::   (MonadUnliftIO m) =>@@ -297,7 +294,7 @@    getTxData th = do     db <- asks (.db)-    retrieveCF db (txCF db) (TxKey th) >>= \case+    liftIO (retrieveCF db (txCF db) (TxKey th)) >>= \case       Nothing -> return Nothing       Just t -> do         withMetrics $ \s -> incrementCounter s.dataTxCount 1@@ -311,7 +308,7 @@   getUnspent p = do     db <- asks (.db)     ctx <- asks (.ctx)-    val <- retrieveCF db (unspentCF db) (UnspentKey p)+    val <- liftIO (retrieveCF db (unspentCF db) (UnspentKey p))     case fmap (valToUnspent ctx p) val of       Nothing -> return Nothing       Just u -> do@@ -321,20 +318,20 @@   getBalance a = do     db <- asks (.db)     withMetrics $ \s -> incrementCounter s.dataBalanceCount 1-    fmap (valToBalance a) <$> retrieveCF db (balanceCF db) (BalKey a)+    fmap (valToBalance a) <$> liftIO (retrieveCF db (balanceCF db) (BalKey a))    getMempool = do     db <- asks (.db)     withMetrics $ \s -> incrementCounter s.dataMempoolCount 1-    fromMaybe [] <$> retrieve db MemKey+    fromMaybe [] <$> liftIO (retrieve db MemKey)    getBestBlock = do     withMetrics $ \s -> incrementCounter s.dataBestCount 1-    asks (.db) >>= (`retrieve` BestKey)+    asks (.db) >>= liftIO . (`retrieve` BestKey)    getBlocksAtHeight h = do     db <- asks (.db)-    retrieveCF db (heightCF db) (HeightKey h) >>= \case+    liftIO (retrieveCF db (heightCF db) (HeightKey h)) >>= \case       Nothing -> return []       Just ls -> do         withMetrics $ \s -> incrementCounter s.dataBlockCount (length ls)@@ -342,7 +339,7 @@    getBlock h = do     db <- asks (.db)-    retrieveCF db (blockCF db) (BlockKey h) >>= \case+    liftIO (retrieveCF db (blockCF db) (BlockKey h)) >>= \case       Nothing -> return Nothing       Just b -> do         withMetrics $ \s -> incrementCounter s.dataBlockCount 1@@ -395,17 +392,16 @@    getInitialGap = asks (.initGap) -  getNumTxData i = do-    db <- asks (.db)+  getNumTxData i = ReaderT $ \r -> do     let (sk, w) = decodeTxKey i-    ls <- liftIO $ matchingAsListCF db (txCF db) (TxKeyS sk)+    ls <- liftIO $ matchingAsListCF r.db (txCF r.db) (TxKeyS sk)     let f t =           let bs = encode $ txHash t.tx               b = BS.head (BS.drop 6 bs)               w' = b .&. 0xf8            in w == w'         txs = filter f $ map snd ls-    withMetrics $ \s -> incrementCounter s.dataTxCount (length txs)+    forM_ r.metrics $ \s -> incrementCounter s.dataTxCount (length txs)     return txs    getBalances as = do@@ -416,8 +412,8 @@    xPubBals xpub = do     ctx <- asks (.ctx)-    igap <- getInitialGap-    gap <- getMaxGap+    igap <- asks (.initGap)+    gap <- asks (.maxGap)     ext1 <- derive_until_gap gap 0 (take (fromIntegral igap) (aderiv ctx 0 0))     if all nullxb ext1       then do

@@ -3,6 +3,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoFieldSelectors #-}@@ -77,38 +78,26 @@ -- | Database key for an address transaction. data AddrTxKey   = -- | key for a transaction affecting an address-    AddrTxKey-      { address :: !Address,-        tx :: !TxRef-      }+    AddrTxKey !Address !TxRef   | -- | short key that matches all entries-    AddrTxKeyA-      { address :: !Address-      }-  | AddrTxKeyB-      { address :: !Address,-        block :: !BlockRef-      }+    AddrTxKeyA !Address+  | AddrTxKeyB !Address !BlockRef   | AddrTxKeyS   deriving (Show, Eq, Ord, Generic, Hashable)  instance Serialize AddrTxKey where   -- 0x05 · Address · BlockRef · TxHash -  put-    AddrTxKey-      { address = a,-        tx = TxRef {block = b, txid = t}-      } = do-      put AddrTxKeyB {address = a, block = b}-      put t+  put (AddrTxKey a TxRef {block = b, txid = t}) = do+    put (AddrTxKeyB a b)+    put t   -- 0x05 · Address-  put AddrTxKeyA {address = a} = do+  put (AddrTxKeyA a) = do     put AddrTxKeyS     put a   -- 0x05 · Address · BlockRef-  put AddrTxKeyB {address = a, block = b} = do-    put AddrTxKeyA {address = a}+  put (AddrTxKeyB a b) = do+    put (AddrTxKeyA a)     put b   -- 0x05   put AddrTxKeyS = putWord8 0x05@@ -117,11 +106,7 @@     a <- get     b <- get     t <- get-    return-      AddrTxKey-        { address = a,-          tx = TxRef {block = b, txid = t}-        }+    return $ AddrTxKey a TxRef {block = b, txid = t}  instance Key AddrTxKey @@ -130,34 +115,25 @@ -- | Database key for an address output. data AddrOutKey   = -- | full key-    AddrOutKey-      { address :: !Address,-        block :: !BlockRef,-        outpoint :: !OutPoint-      }+    AddrOutKey !Address !BlockRef !OutPoint   | -- | short key for all spent or unspent outputs-    AddrOutKeyA-      { address :: !Address-      }-  | AddrOutKeyB-      { address :: !Address,-        block :: !BlockRef-      }+    AddrOutKeyA !Address+  | AddrOutKeyB !Address !BlockRef   | AddrOutKeyS   deriving (Show, Read, Eq, Ord, Generic, Hashable)  instance Serialize AddrOutKey where   -- 0x06 · StoreAddr · BlockRef · OutPoint -  put AddrOutKey {address = a, block = b, outpoint = p} = do-    put AddrOutKeyB {address = a, block = b}+  put (AddrOutKey a b p) = do+    put (AddrOutKeyB a b)     put p   -- 0x06 · StoreAddr · BlockRef-  put AddrOutKeyB {address = a, block = b} = do-    put AddrOutKeyA {address = a}+  put (AddrOutKeyB a b) = do+    put (AddrOutKeyA a)     put b   -- 0x06 · StoreAddr-  put AddrOutKeyA {address = a} = do+  put (AddrOutKeyA a) = do     put AddrOutKeyS     put a   -- 0x06@@ -168,18 +144,15 @@  instance Key AddrOutKey -data OutVal = OutVal-  { value :: !Word64,-    script :: !ByteString-  }+data OutVal = OutVal !Word64 !ByteString   deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize)  instance KeyValue AddrOutKey OutVal  -- | Transaction database key. data TxKey-  = TxKey {txid :: TxHash}-  | TxKeyS {short :: (Word32, Word16)}+  = TxKey !TxHash+  | TxKeyS !(Word32, Word16)   deriving (Show, Read, Eq, Ord, Generic, Hashable)  instance Serialize TxKey where@@ -200,11 +173,14 @@       wb = masked `shift` 11       bs = runPut (putWord64be wb)       g = do-        w1 <- getWord32be-        w2 <- getWord16be-        w3 <- getWord8-        return (w1, w2, w3)-      Right (w1, w2, w3) = runGet g bs+        w1' <- getWord32be+        w2' <- getWord16be+        w3' <- getWord8+        return (w1', w2', w3')+      (w1, w2, w3) =+        case runGet g bs of+          Right x -> x+          Left e -> error e    in ((w1, w2), w3)  instance Key TxKey@@ -213,19 +189,19 @@  -- | Unspent output database key. data UnspentKey-  = UnspentKey {outpoint :: !OutPoint}-  | UnspentKeyS {txid :: !TxHash}+  = UnspentKey !OutPoint+  | UnspentKeyS !TxHash   | UnspentKeyB   deriving (Show, Read, Eq, Ord, Generic, Hashable)  instance Serialize UnspentKey where   -- 0x09 · TxHash · Index-  put UnspentKey {outpoint = OutPoint {hash = h, index = i}} = do+  put (UnspentKey OutPoint {hash = h, index = i}) = do     putWord8 0x09     put h     put i   -- 0x09 · TxHash-  put UnspentKeyS {txid = t} = do+  put (UnspentKeyS t) = do     putWord8 0x09     put t   -- 0x09@@ -240,15 +216,17 @@  instance KeyValue UnspentKey UnspentVal -toUnspent :: Ctx -> AddrOutKey -> OutVal -> Unspent-toUnspent ctx AddrOutKey {..} OutVal {..} =-  Unspent-    { block = block,-      value = value,-      script = script,-      outpoint = outpoint,-      address = eitherToMaybe (scriptToAddressBS ctx script)-    }+toUnspent :: Ctx -> AddrOutKey -> OutVal -> Maybe Unspent+toUnspent ctx (AddrOutKey _address block outpoint) (OutVal value script) =+  Just+    Unspent+      { block = block,+        value = value,+        script = script,+        outpoint = outpoint,+        address = eitherToMaybe (scriptToAddressBS ctx script)+      }+toUnspent _ _ _ = Nothing  -- | Mempool transaction database key. data MemKey@@ -267,9 +245,7 @@ instance KeyValue MemKey [(UnixTime, TxHash)]  -- | Block entry database key.-newtype BlockKey = BlockKey-  { hash :: BlockHash-  }+newtype BlockKey = BlockKey BlockHash   deriving (Show, Read, Eq, Ord, Generic, Hashable)  instance Serialize BlockKey where@@ -286,9 +262,7 @@ instance KeyValue BlockKey BlockData  -- | Block height database key.-newtype HeightKey = HeightKey-  { height :: BlockHeight-  }+newtype HeightKey = HeightKey BlockHeight   deriving (Show, Read, Eq, Ord, Generic, Hashable)  instance Serialize HeightKey where@@ -306,9 +280,7 @@  -- | Address balance database key. data BalKey-  = BalKey-      { address :: !Address-      }+  = BalKey !Address   | BalKeyS   deriving (Show, Read, Eq, Ord, Generic, Hashable) @@ -328,8 +300,7 @@ instance KeyValue BalKey BalVal  -- | Key for best block in database.-data BestKey-  = BestKey+data BestKey = BestKey   deriving (Show, Read, Eq, Ord, Generic, Hashable)  instance Serialize BestKey where@@ -344,8 +315,7 @@ instance KeyValue BestKey BlockHash  -- | Key for database version.-data VersionKey-  = VersionKey+data VersionKey = VersionKey   deriving (Eq, Show, Read, Ord, Generic, Hashable)  instance Serialize VersionKey where

@@ -124,7 +124,7 @@       liftIO $ H.insert outputTable k (Just v)     where       k = (a, u.block, u.outpoint)-      v = OutVal {value = u.value, script = u.script}+      v = OutVal u.value u.script   deleteAddrUnspent a u =     ReaderT $ \Writer {memory = Memory {..}} ->       liftIO $ H.insert outputTable k Nothing@@ -169,7 +169,7 @@   hm <- newMemory net ctx mempool   x <- R.runReaderT f Writer {reader = bdb, memory = hm}   ops <- hashMapOps db hm-  writeBatch db ops+  liftIO $ writeBatch db ops   return x  hashMapOps :: (MonadIO m) => DB -> Memory -> m [BatchOp]@@ -229,21 +229,12 @@     f (a, b, p) (Just l) =       insertOpCF         (addrOutCF db)-        ( AddrOutKey-            { address = a,-              block = b,-              outpoint = p-            }-        )+        (AddrOutKey a b p)         l     f (a, b, p) Nothing =       deleteOpCF         (addrOutCF db)-        AddrOutKey-          { address = a,-            block = b,-            outpoint = p-          }+        (AddrOutKey a b p)  mempoolOp :: (MonadIO m) => MempoolTable -> m [BatchOp] mempoolOp t =

@@ -173,12 +173,12 @@   insertBlock bd {main = False}   $(logDebugS) "BlockStore" $     "Updated as not in main chain: " <> blockHashToHex bh-  forM_ (tail tds) unConfirmTx+  forM_ (drop 1 tds) unConfirmTx   $(logDebugS) "BlockStore" $     "Unconfirmed " <> cs (show (length tds)) <> " transactions"-  deleteConfirmedTx (txHash (head tds).tx)+  deleteConfirmedTx (txHash (tds !! 0).tx)   $(logDebugS) "BlockStore" $-    "Deleted coinbase: " <> txHashToHex (txHash (head tds).tx)+    "Deleted coinbase: " <> txHashToHex (txHash (tds !! 0).tx)  checkNewBlock :: (MonadImport m) => Block -> BlockNode -> m () checkNewBlock b n =@@ -267,7 +267,7 @@   return (bd, tds)   where     ts_out_val =-      sum $ map (sum . map (.value) . (.outputs)) $ tail $ b.txs+      sum $ map (sum . map (.value) . (.outputs)) (drop 1 b.txs)     w =       let f t = (t :: Tx) {witness = []}           b' = (b :: Block) {txs = map f b.txs}

@@ -98,6 +98,7 @@     MonadUnliftIO,     STM,     atomically,+    liftIO,     link,     withAsync,   )@@ -196,7 +197,7 @@   DatabaseReaderT m a ->   m a connectDB cfg f = do-  stats <- mapM createDataMetrics cfg.stats+  stats <- liftIO $ mapM createDataMetrics cfg.stats   withDatabaseReader     cfg.net     cfg.ctx@@ -347,15 +348,15 @@         MNotFound (NotFound is) -> do           let blocks =                 [ BlockHash h-                  | InvVector t h <- is,-                    t == InvBlock || t == InvWitnessBlock+                | InvVector t h <- is,+                  t == InvBlock || t == InvWitnessBlock                 ]           unless (null blocks) $ blockStoreNotFoundSTM p blocks b         MInv (Inv is) -> do           let txs =                 [ TxHash h-                  | InvVector t h <- is,-                    t == InvTx || t == InvWitnessTx+                | InvVector t h <- is,+                  t == InvTx || t == InvWitnessTx                 ]           publishSTM (StoreTxAnnounce p txs) pub           unless (null txs) $ blockStoreTxHashSTM p txs b

@@ -87,7 +87,6 @@   ( encodingToLazyByteString,     list,   )-import Data.Aeson.Text (encodeToLazyText) import Data.Base16.Types (assertBase16) import Data.ByteString.Base16 (decodeBase16, isBase16) import Data.ByteString.Builder (lazyByteString)@@ -120,7 +119,6 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as T-import Data.Text.Lazy (toStrict) import Data.Text.Lazy qualified as TL import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Word (Word32, Word64)@@ -526,7 +524,7 @@     healthCheckLoop v = forever $ do       threadDelay (config.healthCheckInterval * 1000 * 1000)       runHealthCheck >>= atomically . writeTVar v-    opts = def {S.settings = settings defaultSettings}+    opts = S.defaultOptions {S.settings = settings defaultSettings}     settings = setPort config.port . setHost (fromString config.host)  getRates ::@@ -1185,15 +1183,15 @@   Tx ->   m () publishTx cfg tx = do-  ps <- getPeers cfg.store.peerMgr+  ps <- liftIO $ getPeers cfg.store.peerMgr   let c = max 1 (length ps `div` 2)   forM_ (take c ps) $ \p -> do-    sendMessage (MTx tx) p.mailbox+    liftIO $ sendMessage (MTx tx) p.mailbox     void . async $ do       threadDelay (5 * 1000 * 1000)       let v = if cfg.store.net.segWit then InvWitnessTx else InvTx           g = MGetData (GetData [InvVector v (txHash tx).get])-      sendMessage g p.mailbox+      liftIO $ sendMessage g p.mailbox  -- GET Mempool / Events -- @@ -1482,7 +1480,7 @@  getChainHeight :: (MonadUnliftIO m) => ActionT m H.BlockHeight getChainHeight =-  fmap (.height) $ chainGetBest =<< askl (.config.store.chain)+  fmap (.height) $ liftIO . chainGetBest =<< askl (.config.store.chain)  scottyBinfoUnspent :: (MonadUnliftIO m, MonadLoggerIO m) => ActionT m () scottyBinfoUnspent =@@ -2073,7 +2071,7 @@   withMetrics (.binfoQaddressfirstseen) $ do     a <- getAddress =<< S.captureParam "addr"     ch <- askl (.config.store.chain)-    bb <- chainGetBest ch+    bb <- liftIO $ chainGetBest ch     let top = bb.height         bot = 0     i <- go ch bb a bot top@@ -2093,7 +2091,7 @@         | z -> go ch bb a mid top         | otherwise -> return 0     getblocktime ch bb h =-      chainGetAncestor h bb ch >>= \case+      liftIO (chainGetAncestor ch h bb) >>= \case         Just b -> return b.header.timestamp         Nothing -> do           lift . $(logErrorS) "Web" $@@ -2331,7 +2329,7 @@ scottyBinfoGetBlockCount =   withMetrics (.binfoQgetblockcount) $ do     ch <- askl (.config.store.chain)-    bn <- chainGetBest ch+    bn <- liftIO $ chainGetBest ch     setHeaders     S.text $ TL.pack $ show bn.height @@ -2339,7 +2337,7 @@ scottyBinfoLatestHash =   withMetrics (.binfoQlatesthash) $ do     ch <- askl (.config.store.chain)-    bn <- chainGetBest ch+    bn <- liftIO $ chainGetBest ch     setHeaders     S.text $ TL.fromStrict $ H.blockHashToHex $ H.headerHash bn.header @@ -2348,7 +2346,7 @@   withMetrics (.binfoQbcperblock) $ do     ch <- askl (.config.store.chain)     net <- askl (.config.store.net)-    bn <- chainGetBest ch+    bn <- liftIO $ chainGetBest ch     setHeaders     S.text $       cs $@@ -2362,7 +2360,13 @@   withMetrics (.binfoQaddresstohash) $ do     addr <- getAddress =<< S.captureParam "addr"     setHeaders-    S.text $ encodeHexLazy $ runPutL $ serialize addr.hash160+    if+      | Just h <- addressHash160 addr ->+          S.text $ encodeHexLazy $ runPutL $ serialize h+      | Just h <- addressHash256 addr ->+          S.text $ encodeHexLazy $ runPutL $ serialize h+      | otherwise ->+          return ()  scottyBinfoHashToAddr :: (MonadUnliftIO m) => ActionT m () scottyBinfoHashToAddr =@@ -2444,7 +2448,13 @@       Nothing -> raise $ UserError "Could not decode public key"       Just pk -> return $ pubKeyAddr ctx pk     setHeaders-    S.text $ encodeHexLazy $ runPutL $ serialize addr.hash160+    if+      | Just h <- addressHash160 addr ->+          S.text $ encodeHexLazy $ runPutL $ serialize h+      | Just h <- addressHash256 addr ->+          S.text $ encodeHexLazy $ runPutL $ serialize h+      | otherwise ->+          return ()  -- GET Network Information -- @@ -2460,7 +2470,7 @@ getPeersInformation ::   (MonadLoggerIO m) => PeerMgr -> m [PeerInfo] getPeersInformation mgr =-  mapMaybe toInfo <$> getPeers mgr+  mapMaybe toInfo <$> liftIO (getPeers mgr)   where     toInfo op = do       ver <- op.version@@ -2487,7 +2497,7 @@   m BlockHealth blockHealthCheck cfg = do   let ch = cfg.store.chain-  headers <- (.height) <$> chainGetBest ch+  headers <- (.height) <$> liftIO (chainGetBest ch)   blocks <-     maybe 0 (.height)       <$> runMaybeT (MaybeT getBestBlock >>= MaybeT . getBlock)@@ -2505,7 +2515,7 @@   m TimeHealth lastBlockHealthCheck ch WebLimits {blockTimeout} = do   n <- round <$> liftIO getPOSIXTime-  t <- fromIntegral . (.header.timestamp) <$> chainGetBest ch+  t <- fromIntegral . (.header.timestamp) <$> liftIO (chainGetBest ch)   return     TimeHealth       { age = n - t,@@ -2518,7 +2528,7 @@   m TimeHealth lastTxHealthCheck WebConfig {noMempool, store = store', limits} = do   n <- round <$> liftIO getPOSIXTime-  b <- fromIntegral . (.header.timestamp) <$> chainGetBest ch+  b <- fromIntegral . (.header.timestamp) <$> liftIO (chainGetBest ch)   t <-     getMempool >>= \case       t : _ ->@@ -2554,13 +2564,11 @@   WebConfig ->   m CountHealth peerHealthCheck cfg = do-  count <- fromIntegral . length <$> getPeers cfg.store.peerMgr+  count <- fromIntegral . length <$> liftIO (getPeers cfg.store.peerMgr)   return CountHealth {min = fromIntegral cfg.minPeers, count}  healthCheck ::-  (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) =>-  WebConfig ->-  m HealthCheck+  (MonadUnliftIO m, StoreReadBase m) => WebConfig -> m HealthCheck healthCheck cfg = do   blocks <- blockHealthCheck cfg   lastBlock <- lastBlockHealthCheck cfg.store.chain cfg.limits@@ -2568,23 +2576,19 @@   pendingTxs <- pendingTxsHealthCheck cfg   peers <- peerHealthCheck cfg   time <- round <$> liftIO getPOSIXTime-  let check =-        HealthCheck-          { network = cfg.store.net.name,-            version = cfg.version,-            ..-          }-  unless (isOK check) $ do-    let t = toStrict $ encodeToLazyText check-    $(logErrorS) "Web" $ "Health check failed: " <> t-  return check+  return+    HealthCheck+      { network = cfg.store.net.name,+        version = cfg.version,+        ..+      }  scottyDbStats :: (MonadUnliftIO m) => ActionT m () scottyDbStats =   withMetrics (.db) $ do     setHeaders     db <- askl (.config.store.db.db)-    statsM <- lift (getProperty db Stats)+    statsM <- liftIO (getProperty db Stats)     S.text $ maybe "Could not get stats" cs statsM  -----------------------

@@ -18,7 +18,7 @@ import Data.ByteString.Base64 import Data.Either import Data.List (find)-import Data.Maybe (fromJust, fromMaybe, isJust, mapMaybe)+import Data.Maybe import Data.Serialize import Data.Time.Clock.POSIX import Data.Word@@ -47,7 +47,7 @@           StoreBestBlock b -> Just b           _ -> Nothing         let bestHash = last bs-        bestNodeM <- chainGetBlock bestHash testStoreChain+        bestNodeM <- liftIO $ chainGetBlock testStoreChain bestHash         bestNodeM `shouldSatisfy` isJust         let bestNode = fromJust bestNodeM             bestHeight = bestNode.height@@ -70,9 +70,8 @@           lift $ do             bd.height `shouldBe` 15             length bd.txs `shouldBe` 1-            head bd.txs `shouldBe` h1-            t1 `shouldSatisfy` isJust-            txHash (transactionData (fromJust t1)) `shouldBe` h1+            listToMaybe bd.txs `shouldBe` Just h1+            fmap (txHash . transactionData) t1 `shouldBe` Just h1  withTestStore ::   (MonadUnliftIO m) =>