packages feed

haskoin-store 0.18.11 → 0.19.0

raw patch · 11 files changed

+113/−126 lines, 11 files

Files

CHANGELOG.md view
@@ -4,6 +4,10 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). +## 0.19.0+### Changed+- Store mempool in single key/value pair.+ ## 0.18.11 ### Changed - Do not stream mempool.
haskoin-store.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 6be250e9b16bba227b422d9b4a7951d78ed9e1245c9b5cf413b7c319ca9579a2+-- hash: fe4dcb1be7cd549a159dc229dee4efedea2fb429d57179817b96f75c5e8400f0  name:           haskoin-store-version:        0.18.11+version:        0.19.0 synopsis:       Storage and index for Bitcoin and Bitcoin Cash description:    Store blocks, transactions, and balances for Bitcoin or Bitcoin Cash, and make that information via REST API. category:       Bitcoin, Finance, Network
src/Network/Haskoin/Store/Block.hs view
@@ -78,10 +78,10 @@     getOrphanTx = runLayered . getOrphanTx     getUnspent = runLayered . getUnspent     getBalance = runLayered . getBalance+    getMempool = runLayered getMempool  instance (MonadResource m, MonadUnliftIO m) =>          StoreStream (ReaderT BlockRead m) where-    getMempool = transPipe runLayered getMempool     getOrphans = transPipe runLayered getOrphans     getAddressUnspents a x = transPipe runLayered $ getAddressUnspents a x     getAddressTxs a x = transPipe runLayered $ getAddressTxs a x
src/Network/Haskoin/Store/Data.hs view
@@ -78,6 +78,7 @@     getSpender :: OutPoint -> m (Maybe Spender)     getBalance :: Address -> m (Maybe Balance)     getUnspent :: OutPoint -> m (Maybe Unspent)+    getMempool :: m [(UnixTime, TxHash)]  class StoreWrite m where     setInit :: m ()@@ -91,8 +92,7 @@     deleteAddrTx :: Address -> BlockTx -> m ()     insertAddrUnspent :: Address -> Unspent -> m ()     deleteAddrUnspent :: Address -> Unspent -> m ()-    insertMempoolTx :: TxHash -> UnixTime -> m ()-    deleteMempoolTx :: TxHash -> UnixTime -> m ()+    setMempool :: [(UnixTime, TxHash)] -> m ()     insertOrphanTx :: Tx -> UnixTime -> m ()     deleteOrphanTx :: TxHash -> m ()     setBalance :: Balance -> m ()@@ -125,7 +125,6 @@     t = fromIntegral . blockTimestamp . blockDataHeader  class StoreStream m where-    getMempool :: ConduitT i (UnixTime, TxHash) m ()     getOrphans :: ConduitT i (UnixTime, Tx) m ()     getAddressUnspents :: Address -> Maybe BlockRef -> ConduitT i Unspent m ()     getAddressTxs :: Address -> Maybe BlockRef -> ConduitT i BlockTx m ()
src/Network/Haskoin/Store/Data/Cached.hs view
@@ -32,7 +32,7 @@ newLayeredDB blocks (Just cache) = do     bulkCopy opts db cdb BalKeyS     bulkCopy opts db cdb UnspentKeyB-    bulkCopy opts db cdb MemKeyS+    bulkCopy opts db cdb MemKey     return LayeredDB {layeredDB = blocks, layeredCache = Just cache}   where     BlockDB {blockDBopts = opts, blockDB = db} = blocks@@ -77,10 +77,7 @@        (MonadResource m, MonadIO m) => LayeredDB -> ConduitT i Unspent m () getUnspentsC LayeredDB {layeredDB = db} = getUnspentsDB db -getMempoolC ::-       (MonadResource m, MonadUnliftIO m)-    => LayeredDB-    -> ConduitT i (UnixTime, TxHash) m ()+getMempoolC :: MonadIO m => LayeredDB -> m [(UnixTime, TxHash)] getMempoolC LayeredDB {layeredCache = Just db} = getMempoolDB db getMempoolC LayeredDB {layeredDB = db}         = getMempoolDB db @@ -147,9 +144,6 @@  instance (MonadUnliftIO m, MonadResource m) =>          StoreStream (ReaderT LayeredDB m) where-    getMempool = do-        c <- R.ask-        getMempoolC c     getOrphans = do         c <- R.ask         getOrphansC c@@ -197,3 +191,6 @@     getBalance a = do         c <- R.ask         getBalanceC a c+    getMempool = do+        c <- R.ask+        getMempoolC c
src/Network/Haskoin/Store/Data/ImportDB.hs view
@@ -71,13 +71,14 @@     balOps (hBalance db) <>     addrTxOps (hAddrTx db) <>     addrOutOps (hAddrOut db) <>-    mempoolOps (hMempool db) <>+    maybeToList (mempoolOp <$> hMempool db) <>     orphanOps (hOrphans db) <>     unspentOps (hUnspent db)  cacheMapOps :: BlockMem -> [BatchOp] cacheMapOps db =-    balOps (hBalance db) <> mempoolOps (hMempool db) <> unspentOps (hUnspent db)+    balOps (hBalance db) <> maybeToList (mempoolOp <$> hMempool db) <>+    unspentOps (hUnspent db)  bestBlockOp :: Maybe BlockHash -> [BatchOp] bestBlockOp Nothing  = []@@ -152,13 +153,8 @@     h a b p Nothing =         deleteOp AddrOutKey {addrOutKeyA = a, addrOutKeyB = b, addrOutKeyP = p} -mempoolOps ::-       HashMap UnixTime (HashMap TxHash Bool) -> [BatchOp]-mempoolOps = concatMap (uncurry f) . M.toList-  where-    f u = map (uncurry (g u)) . M.toList-    g u t True  = insertOp (MemKey u t) ()-    g u t False = deleteOp (MemKey u t)+mempoolOp :: [(UnixTime, TxHash)] -> BatchOp+mempoolOp = insertOp MemKey  orphanOps :: HashMap TxHash (Maybe (UnixTime, Tx)) -> [BatchOp] orphanOps = map (uncurry f) . M.toList@@ -224,13 +220,8 @@ deleteAddrUnspentI a u ImportDB {importHashMap = hm} =     withBlockMem hm $ deleteAddrUnspent a u -insertMempoolTxI :: MonadIO m => TxHash -> UnixTime -> ImportDB -> m ()-insertMempoolTxI t p ImportDB {importHashMap = hm} =-    withBlockMem hm $ insertMempoolTx t p--deleteMempoolTxI :: MonadIO m => TxHash -> UnixTime -> ImportDB -> m ()-deleteMempoolTxI t p ImportDB {importHashMap = hm} =-    withBlockMem hm $ deleteMempoolTx t p+setMempoolI :: MonadIO m => [(UnixTime, TxHash)] -> ImportDB -> m ()+setMempoolI xs ImportDB {importHashMap = hm} = withBlockMem hm $ setMempool xs  insertOrphanTxI :: MonadIO m => Tx -> UnixTime -> ImportDB -> m () insertOrphanTxI t p ImportDB {importHashMap = hm} =@@ -317,19 +308,11 @@ getMempoolI ::        MonadIO m     => ImportDB-    -> ConduitT i (UnixTime, TxHash) m ()-getMempoolI ImportDB {importHashMap = hm, importLayeredDB = db} = do-    h <- hMempool <$> readTVarIO hm-    let hmap =-            M.fromList $-            concatMap-                (\(u, l) -> map (\(t, b) -> ((u, t), b)) (M.toList l))-                (M.toList h)-    dmap <--        fmap M.fromList . liftIO . runResourceT . withLayeredDB db . runConduit $-        getMempool .| mapC (, True) .| sinkList-    let rmap = M.filter id (M.union hmap dmap)-    yieldMany $ sortBy (flip compare) (M.keys rmap)+    -> m [(UnixTime, TxHash)]+getMempoolI ImportDB {importHashMap = hm, importLayeredDB = db} =+    getMempoolH <$> readTVarIO hm >>= \case+      Just xs -> return xs+      Nothing -> withLayeredDB db getMempool  instance MonadIO m => StoreRead (ReaderT ImportDB m) where     isInitialized = R.ask >>= isInitializedI@@ -342,6 +325,7 @@     getOrphanTx h = R.ask >>= getOrphanTxI h     getUnspent a = R.ask >>= getUnspentI a     getBalance a = R.ask >>= getBalanceI a+    getMempool = R.ask >>= getMempoolI  instance MonadIO m => StoreWrite (ReaderT ImportDB m) where     setInit = R.ask >>= setInitI@@ -355,8 +339,7 @@     deleteAddrTx a t = R.ask >>= deleteAddrTxI a t     insertAddrUnspent a u = R.ask >>= insertAddrUnspentI a u     deleteAddrUnspent a u = R.ask >>= deleteAddrUnspentI a u-    insertMempoolTx t p = R.ask >>= insertMempoolTxI t p-    deleteMempoolTx t p = R.ask >>= deleteMempoolTxI t p+    setMempool xs = R.ask >>= setMempoolI xs     insertOrphanTx t p = R.ask >>= insertOrphanTxI t p     deleteOrphanTx t = R.ask >>= deleteOrphanTxI t     insertUnspent u = R.ask >>= insertUnspentI u@@ -364,7 +347,6 @@     setBalance b = R.ask >>= setBalanceI b  instance MonadIO m => StoreStream (ReaderT ImportDB m) where-    getMempool = R.ask >>= getMempoolI     getOrphans = undefined     getAddressUnspents a m = undefined     getAddressTxs a m = undefined
src/Network/Haskoin/Store/Data/KeyValue.hs view
@@ -69,7 +69,6 @@                 }  instance R.Key AddrTxKey- instance R.KeyValue AddrTxKey ()  -- | Database key for an address output.@@ -133,7 +132,6 @@         TxKey <$> get  instance R.Key TxKey- instance R.KeyValue TxKey TxData  data SpenderKey@@ -156,7 +154,6 @@         return $ SpenderKey op  instance R.Key SpenderKey- instance R.KeyValue SpenderKey Spender  -- | Unspent output database key.@@ -186,35 +183,23 @@         return $ UnspentKey OutPoint {outPointHash = h, outPointIndex = i}  instance R.Key UnspentKey- instance R.KeyValue UnspentKey UnspentVal  -- | Mempool transaction database key.-data MemKey-    = MemKey { memTime :: !UnixTime-             , memKey  :: !TxHash }-    | MemKeyT { memTime :: !UnixTime }-    | MemKeyS-    deriving (Show, Read, Eq, Ord, Generic, Hashable)+data MemKey =+    MemKey+    deriving (Show, Read)  instance Serialize MemKey where-    -- 0x07 · UnixTime · TxHash-    put (MemKey t h) = do-        putWord8 0x07-        putUnixTime t-        put h-    -- 0x07 · UnixTime-    put (MemKeyT t) = do-        putWord8 0x07-        putUnixTime t     -- 0x07-    put MemKeyS = putWord8 0x07+    put MemKey = do+        putWord8 0x07     get = do         guard . (== 0x07) =<< getWord8-        MemKey <$> getUnixTime <*> get+        return MemKey  instance R.Key MemKey-instance R.KeyValue MemKey ()+instance R.KeyValue MemKey [(UnixTime, TxHash)]  -- | Orphan pool transaction database key. data OrphanKey@@ -270,7 +255,6 @@         HeightKey <$> get  instance R.Key HeightKey- instance R.KeyValue HeightKey [BlockHash]  -- | Address balance database key.@@ -293,7 +277,6 @@         BalKey <$> get  instance R.Key BalKey- instance R.KeyValue BalKey BalVal  -- | Key for best block in database.@@ -309,7 +292,6 @@         return BestKey  instance R.Key BestKey- instance R.KeyValue BestKey BlockHash  -- | Key for database version.@@ -325,5 +307,36 @@         return VersionKey  instance R.Key VersionKey- instance R.KeyValue VersionKey Word32+++-- | Old mempool transaction database key.+data OldMemKey+    = OldMemKey+          { memTime :: !UnixTime+          , memKey  :: !TxHash+          }+    | OldMemKeyT+          { memTime :: !UnixTime+          }+    | OldMemKeyS+    deriving (Show, Read, Eq, Ord, Generic, Hashable)++instance Serialize OldMemKey where+    -- 0x07 · UnixTime · TxHash+    put (OldMemKey t h) = do+        putWord8 0x07+        putUnixTime t+        put h+    -- 0x07 · UnixTime+    put (OldMemKeyT t) = do+        putWord8 0x07+        putUnixTime t+    -- 0x07+    put OldMemKeyS = putWord8 0x07+    get = do+        guard . (== 0x07) =<< getWord8+        OldMemKey <$> getUnixTime <*> get++instance R.Key OldMemKey+instance R.KeyValue OldMemKey ()
src/Network/Haskoin/Store/Data/Memory.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE FlexibleInstances    #-}-{-# LANGUAGE TupleSections        #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TupleSections     #-} {-# OPTIONS_GHC -Wno-orphans #-} module Network.Haskoin.Store.Data.Memory where @@ -16,6 +16,7 @@ import qualified Data.IntMap.Strict                  as I import           Data.List import           Data.Maybe+import           Data.Tuple                          (swap) import           Haskoin import           Network.Haskoin.Store.Data import           Network.Haskoin.Store.Data.KeyValue@@ -35,7 +36,7 @@     , hBalance :: !(HashMap Address BalVal)     , hAddrTx :: !(HashMap Address (HashMap BlockRef (HashMap TxHash Bool)))     , hAddrOut :: !(HashMap Address (HashMap BlockRef (HashMap OutPoint (Maybe OutVal))))-    , hMempool :: !(HashMap UnixTime (HashMap TxHash Bool))+    , hMempool :: !(Maybe [(UnixTime, TxHash)])     , hOrphans :: !(HashMap TxHash (Maybe (UnixTime, Tx)))     , hInit :: !Bool     } deriving (Eq, Show)@@ -52,7 +53,7 @@         , hBalance = M.empty         , hAddrTx = M.empty         , hAddrOut = M.empty-        , hMempool = M.empty+        , hMempool = Nothing         , hOrphans = M.empty         , hInit = False         }@@ -83,12 +84,8 @@ getBalanceH :: Address -> BlockMem -> Maybe Balance getBalanceH a = fmap (balValToBalance a) . M.lookup a . hBalance -getMempoolH :: Monad m => BlockMem -> ConduitT i (UnixTime, TxHash) m ()-getMempoolH db =-    let ls =-            sortBy (flip compare) . M.toList . M.map (M.keys . M.filter id) $-            hMempool db-     in yieldMany [(u, h) | (u, hs) <- ls, h <- hs]+getMempoolH :: BlockMem -> Maybe [(UnixTime, TxHash)]+getMempoolH = hMempool  getOrphansH :: Monad m => BlockMem -> ConduitT i (UnixTime, Tx) m () getOrphansH = yieldMany . catMaybes . M.elems . hOrphans@@ -238,15 +235,8 @@                      (M.singleton (unspentPoint u) Nothing))      in db {hAddrOut = M.unionWith (M.unionWith M.union) s (hAddrOut db)} -insertMempoolTxH :: TxHash -> UnixTime -> BlockMem -> BlockMem-insertMempoolTxH h u db =-    let s = M.singleton u (M.singleton h True)-     in db {hMempool = M.unionWith M.union s (hMempool db)}--deleteMempoolTxH :: TxHash -> UnixTime -> BlockMem -> BlockMem-deleteMempoolTxH h u db =-    let s = M.singleton u (M.singleton h False)-     in db {hMempool = M.unionWith M.union s (hMempool db)}+setMempoolH :: [(UnixTime, TxHash)] -> BlockMem -> BlockMem+setMempoolH xs db = db {hMempool = Just xs}  insertOrphanTxH :: Tx -> UnixTime -> BlockMem -> BlockMem insertOrphanTxH tx u db =@@ -315,11 +305,11 @@     getBalance a = do         v <- R.ask >>= readTVarIO         return $ getBalanceH a v--instance MonadIO m => StoreStream (ReaderT (TVar BlockMem) m) where     getMempool = do         v <- R.ask >>= readTVarIO-        getMempoolH v+        return . fromMaybe [] $ getMempoolH v++instance MonadIO m => StoreStream (ReaderT (TVar BlockMem) m) where     getOrphans = do         v <- R.ask >>= readTVarIO         getOrphansH v@@ -370,12 +360,9 @@     deleteAddrUnspent a u = do         v <- R.ask         atomically $ modifyTVar v (deleteAddrUnspentH a u)-    insertMempoolTx h t = do-        v <- R.ask-        atomically $ modifyTVar v (insertMempoolTxH h t)-    deleteMempoolTx h t = do+    setMempool xs = do         v <- R.ask-        atomically $ modifyTVar v (deleteMempoolTxH h t)+        atomically $ modifyTVar v (setMempoolH xs)     insertOrphanTx t u = do         v <- R.ask         atomically $ modifyTVar v (insertOrphanTxH t u)
src/Network/Haskoin/Store/Data/RocksDB.hs view
@@ -9,6 +9,7 @@ import qualified Data.ByteString.Short               as B.Short import           Data.IntMap                         (IntMap) import qualified Data.IntMap.Strict                  as I+import           Data.Maybe                          (fromMaybe) import           Data.Word import           Database.RocksDB                    (DB, ReadOptions) import           Database.RocksDB.Query@@ -18,16 +19,25 @@ import           UnliftIO  dataVersion :: Word32-dataVersion = 15+dataVersion = 16  isInitializedDB :: MonadIO m => BlockDB -> m (Either InitException Bool)-isInitializedDB BlockDB {blockDBopts = opts, blockDB = db} =+isInitializedDB bdb@BlockDB {blockDBopts = opts, blockDB = db} =     retrieve db opts VersionKey >>= \case         Just v             | v == dataVersion -> return (Right True)+            | v == 15 -> migrate15to16 bdb             | otherwise -> return (Left (IncorrectVersion v))         Nothing -> return (Right False) +migrate15to16 :: MonadIO m => BlockDB -> m (Either InitException Bool)+migrate15to16 bdb@BlockDB {blockDBopts = opts, blockDB = db} = do+    xs <- liftIO $ matchingAsList db opts OldMemKeyS+    let ys = map (\(OldMemKey t h, ()) -> (t, h)) xs+    insert db MemKey ys+    insert db VersionKey (16 :: Word32)+    isInitializedDB bdb+ setInitDB :: MonadIO m => DB -> m () setInitDB db = insert db VersionKey dataVersion @@ -66,16 +76,9 @@ getBalanceDB a BlockDB {blockDBopts = opts, blockDB = db} =     fmap (balValToBalance a) <$> retrieve db opts (BalKey a) -getMempoolDB ::-       (MonadIO m, MonadResource m)-    => BlockDB-    -> ConduitT i (UnixTime, TxHash) m ()+getMempoolDB :: MonadIO m => BlockDB -> m [(UnixTime, TxHash)] getMempoolDB BlockDB {blockDBopts = opts, blockDB = db} =-    x .| mapC (uncurry f)-  where-    x = matching db opts MemKeyS-    f (MemKey u t) () = (u, t)-    f _ _             = undefined+    fromMaybe [] <$> retrieve db opts MemKey  getOrphansDB ::        (MonadIO m, MonadResource m)
src/Network/Haskoin/Store/Logic.hs view
@@ -230,9 +230,7 @@     -> BlockNode     -> m () importBlock net b n = do-    mp <--        runConduit $-        getMempool .| mapC snd .| filterC (`elem` bths) .| sinkList+    mp <- filter (`elem` bths) . map snd <$> getMempool     getBestBlock >>= \case         Nothing             | isGenesis n -> do@@ -374,7 +372,7 @@     let (d, _) = fromTransaction t     insertTx d     updateAddressCounts net (txAddresses t) (+ 1)-    unless (confirmed br) $ insertMempoolTx (txHash tx) (memRefTime br)+    unless (confirmed br) $ insertIntoMempool (txHash tx) (memRefTime br)   where     uns op =         getUnspent op >>= \case@@ -507,7 +505,7 @@                     reduceBalance net False False a (outValue o)                     increaseBalance True False a (outValue o)     insertTx t {txDataBlock = br}-    deleteMempoolTx (txHash tx) (memRefTime (txDataBlock t))+    deleteFromMempool (txHash tx)  getRecursiveTx ::        (Monad m, StoreRead m, MonadLogger m) => TxHash -> m [Transaction]@@ -521,6 +519,16 @@                 let ss = nub . map spenderHash $ I.elems sm                 concat <$> mapM getRecursiveTx ss +deleteFromMempool :: (Monad m, StoreRead m, StoreWrite m) => TxHash -> m ()+deleteFromMempool th = do+    mp <- getMempool+    setMempool $ filter ((/= th) . snd) mp++insertIntoMempool :: (Monad m, StoreRead m, StoreWrite m) => TxHash -> UnixTime -> m ()+insertIntoMempool th unixtime = do+    mp <- getMempool+    setMempool $ sortBy (flip compare) ((unixtime, th) : mp)+ deleteTx ::        ( StoreRead m        , StoreWrite m@@ -556,8 +564,7 @@             delOutput net (OutPoint h n)         let ps = filter (/= nullOutPoint) (map prevOutput (txIn (txData t)))         mapM_ (unspendOutput net) ps-        unless (confirmed (txDataBlock t)) $-            deleteMempoolTx h (memRefTime (txDataBlock t))+        unless (confirmed (txDataBlock t)) $ deleteFromMempool h         insertTx t {txDataDeleted = True}         updateAddressCounts net (txDataAddresses t) (subtract 1)
src/Network/Haskoin/Store/Web.hs view
@@ -185,6 +185,7 @@     getOrphanTx = lift . getOrphanTx     getUnspent = lift . getUnspent     getBalance = lift . getBalance+    getMempool = lift getMempool  askDB :: Monad m => WebT m LayeredDB askDB = lift R.ask@@ -344,8 +345,7 @@ scottyMempool net = do     cors     proto <- setupBin-    db <- askDB-    txs <- liftIO . runStream db $ runConduit $ getMempoolStream .| sinkList+    txs <- map snd <$> getMempool     protoSerial net proto txs  scottyTransaction :: MonadLoggerIO m => Network -> WebT m ()@@ -935,7 +935,7 @@     maybe_chain_best <- timeout (5 * 1000 * 1000) $ chainGetBest ch     maybe_block_best <- runMaybeT $ MaybeT . getBlock =<< MaybeT getBestBlock     peers <- timeout (5 * 1000 * 1000) $ managerGetPeers mgr-    maybe_mempool_last <- runConduit $ getMempool .| mapC fst .| headC+    maybe_mempool_last <- fmap fst . listToMaybe <$> getMempool     now <- fromIntegral . systemSeconds <$> liftIO getSystemTime     let maybe_block_time_delta =             (now -) . fromIntegral . blockTimestamp . blockDataHeader <$>@@ -1184,11 +1184,6 @@              in if f z x == GT                     then find_idx a c                     else find_idx c b--getMempoolStream ::-       (Monad m, StoreStream m)-    => ConduitT i TxHash m ()-getMempoolStream = getMempool .| mapC snd  getAddressTxsLimit ::        (Monad m, StoreStream m)