diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -16,6 +16,7 @@ import Data.List (intercalate) import Data.Maybe (fromMaybe) import Data.String.Conversions (cs) +import Data.Word (Word32) import Haskoin (Network (..), allNets, bch, bchRegTest, bchTest, btc, btcRegTest, btcTest, eitherToMaybe) @@ -49,6 +50,7 @@ , configHost :: !String , configPort :: !Int , configNetwork :: !Network + , configAsert :: !Word32 , configDiscover :: !Bool , configPeers :: ![(String, Maybe Int)] , configVersion :: !Bool @@ -75,6 +77,7 @@ , configHost = defHost , configPort = defPort , configNetwork = defNetwork + , configAsert = defAsert , configDiscover = defDiscover , configPeers = defPeers , configVersion = False @@ -137,6 +140,11 @@ defEnv "NET" bch (eitherToMaybe . networkReader) {-# NOINLINE defNetwork #-} +defAsert :: Word32 +defAsert = unsafePerformIO $ + defEnv "ASERT" 0 readMaybe +{-# NOINLINE defAsert #-} + defRedisMin :: Int defRedisMin = unsafePerformIO $ defEnv "CACHE_MIN" 100 readMaybe @@ -275,6 +283,12 @@ <> help "Network to connect to" <> showDefault <> value (configNetwork def) + configAsert <- + option auto $ + metavar "TIME" + <> long "asert" + <> help "ASERT (axon) activation time" + <> value (configAsert def) configDiscover <- flag (configDiscover def) True $ long "discover" @@ -481,6 +495,7 @@ run Config { configHost = host , configPort = port , configNetwork = net + , configAsert = asert , configDiscover = disc , configPeers = peers , configDir = db_dir @@ -512,7 +527,7 @@ map (second (fromMaybe (getDefaultPort net))) peers , storeConfDiscover = disc , storeConfDB = wd "db" - , storeConfNetwork = net + , storeConfNetwork = net' , storeConfCache = if redis then Just redisurl @@ -543,7 +558,9 @@ , webNoMempool = nomem } where + net' | asert == 0 = net + | otherwise = net { getAsertActivationTime = Just asert } l _ lvl | deb = True | otherwise = LevelInfo <= lvl - wd = db_dir getNetworkName net + wd = db_dir getNetworkName net' diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -1,13 +1,13 @@ cabal-version: 2.0 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.2. -- -- see: https://github.com/sol/hpack -- --- hash: 6706ddf8dce4c42481f5013333abf722c72156f93f2e540ce10c8c8086eb9d13 +-- hash: b1a8d34c8b0abb61f5882a9454a5c93e684db97d46d01e20eb7bc24cfc02c188 name: haskoin-store -version: 0.37.5 +version: 0.38.0 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -53,7 +53,7 @@ , hashable >=1.3.0.0 , haskoin-core >=0.13.6 , haskoin-node >=0.14.1 - , haskoin-store-data ==0.37.5 + , haskoin-store-data ==0.38.0 , hedis >=0.12.13 , http-types >=0.12.3 , monad-logger >=0.3.32 @@ -96,7 +96,7 @@ , haskoin-core >=0.13.6 , haskoin-node >=0.14.1 , haskoin-store - , haskoin-store-data ==0.37.5 + , haskoin-store-data ==0.38.0 , monad-logger >=0.3.32 , mtl >=2.2.2 , nqe >=0.6.1 @@ -135,8 +135,8 @@ , hashable >=1.3.0.0 , haskoin-core >=0.13.6 , haskoin-node >=0.14.1 - , haskoin-store ==0.37.5 - , haskoin-store-data ==0.37.5 + , haskoin-store ==0.38.0 + , haskoin-store-data ==0.38.0 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3 diff --git a/src/Haskoin/Store/Common.hs b/src/Haskoin/Store/Common.hs --- a/src/Haskoin/Store/Common.hs +++ b/src/Haskoin/Store/Common.hs @@ -22,6 +22,7 @@ , xPubBalsUnspents , getTransaction , blockAtOrBefore + , blockAtOrAfterMTP , deOffset , applyLimits , applyLimitsC @@ -30,45 +31,48 @@ , microseconds ) where -import Conduit (ConduitT, dropC, mapC, takeC) -import Control.DeepSeq (NFData) -import Control.Exception (Exception) -import Control.Monad (mzero) -import Control.Monad.Trans (lift) -import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) -import Data.ByteString (ByteString) -import Data.Default (Default (..)) -import Data.Function (on) -import Data.Hashable (Hashable) -import qualified Data.HashSet as H -import Data.IntMap.Strict (IntMap) -import qualified Data.IntMap.Strict as I -import Data.List (sortBy) -import Data.Maybe (catMaybes, listToMaybe) -import Data.Serialize (Serialize (..)) -import Data.Time.Clock.System (getSystemTime, systemNanoseconds, - systemSeconds) -import Data.Word (Word32, Word64) -import GHC.Generics (Generic) -import Haskoin (Address, BlockHash, - BlockHeader (..), BlockHeight, - KeyIndex, Network (..), - OutPoint (..), RejectCode (..), - Tx (..), TxHash (..), TxIn (..), - XPubKey (..), deriveAddr, - deriveCompatWitnessAddr, - deriveWitnessAddr, pubSubKey, - txHash) -import Haskoin.Node (Peer) -import Haskoin.Store.Data (Balance (..), BlockData (..), - DeriveType (..), Spender, - Transaction, TxData (..), - TxRef (..), UnixTime, Unspent (..), - XPubBal (..), XPubSpec (..), - XPubSummary (..), XPubUnspent (..), - nullBalance, toTransaction, - zeroBalance) -import UnliftIO (MonadIO, liftIO) +import Conduit (ConduitT, dropC, mapC, takeC) +import Control.DeepSeq (NFData) +import Control.Exception (Exception) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) +import Control.Monad.Trans.Reader (runReaderT) +import Data.ByteString (ByteString) +import Data.Default (Default (..)) +import Data.Function (on) +import Data.Hashable (Hashable) +import qualified Data.HashSet as H +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as I +import Data.List (sortBy) +import Data.Maybe (catMaybes) +import Data.Serialize (Serialize (..)) +import Data.Time.Clock.System (getSystemTime, systemNanoseconds, + systemSeconds) +import Data.Word (Word32, Word64) +import GHC.Generics (Generic) +import Haskoin (Address, BlockHash, + BlockHeader (..), BlockHeight, + BlockNode (..), KeyIndex, + Network (..), OutPoint (..), + RejectCode (..), Tx (..), + TxHash (..), TxIn (..), + XPubKey (..), deriveAddr, + deriveCompatWitnessAddr, + deriveWitnessAddr, + firstGreaterOrEqual, headerHash, + lastSmallerOrEqual, mtp, pubSubKey, + txHash) +import Haskoin.Node (Chain, Peer) +import Haskoin.Store.Data (Balance (..), BlockData (..), + DeriveType (..), Spender, + Transaction, TxData (..), + TxRef (..), UnixTime, Unspent (..), + XPubBal (..), XPubSpec (..), + XPubSummary (..), XPubUnspent (..), + nullBalance, toTransaction, + zeroBalance) +import UnliftIO (MonadIO, liftIO) type DeriveAddr = XPubKey -> KeyIndex -> Address @@ -273,25 +277,31 @@ sm <- lift $ getSpenders h return $ toTransaction d sm -blockAtOrBefore :: (Monad m, StoreReadExtra m) - => UnixTime +blockAtOrBefore :: (MonadIO m, StoreReadExtra m) + => Chain + -> UnixTime -> m (Maybe BlockData) -blockAtOrBefore q = runMaybeT $ do - a <- g 0 - b <- MaybeT getBestBlock >>= MaybeT . getBlock - f a b +blockAtOrBefore ch q = runMaybeT $ do + net <- lift getNetwork + x <- MaybeT $ liftIO $ runReaderT (lastSmallerOrEqual net f) ch + MaybeT $ getBlock (headerHash (nodeHeader x)) where - f a b - | t b <= q = return b - | t a > q = mzero - | h b - h a == 1 = return a - | otherwise = do - let x = h a + (h b - h a) `div` 2 - m <- g x - if t m > q then f a m else f m b - g x = MaybeT (listToMaybe <$> getBlocksAtHeight x) >>= MaybeT . getBlock - h = blockDataHeight - t = fromIntegral . blockTimestamp . blockDataHeader + f x = + let t = fromIntegral (blockTimestamp (nodeHeader x)) + in return $ t `compare` q + +blockAtOrAfterMTP :: (MonadIO m, StoreReadExtra m) + => Chain + -> UnixTime + -> m (Maybe BlockData) +blockAtOrAfterMTP ch q = runMaybeT $ do + net <- lift getNetwork + x <- MaybeT $ liftIO $ runReaderT (firstGreaterOrEqual net f) ch + MaybeT $ getBlock (headerHash (nodeHeader x)) + where + f x = do + t <- fromIntegral <$> mtp x + return $ t `compare` q -- | Events that the store can generate. diff --git a/src/Haskoin/Store/Web.hs b/src/Haskoin/Store/Web.hs --- a/src/Haskoin/Store/Web.hs +++ b/src/Haskoin/Store/Web.hs @@ -263,6 +263,16 @@ scottyBlockTimeRaw (const toEncoding) (const toJSON) + pathPretty + (GetBlockMTP <$> paramLazy <*> paramDef) + scottyBlockMTP + blockDataToEncoding + blockDataToJSON + pathCompact + (GetBlockMTPRaw <$> paramLazy) + scottyBlockMTPRaw + (const toEncoding) + (const toJSON) -- Transaction Paths pathPretty (GetTx <$> paramLazy) @@ -566,20 +576,38 @@ -- GET BlockTime / BlockTimeRaw -- -scottyBlockTime :: - (MonadUnliftIO m, MonadLoggerIO m) => GetBlockTime -> WebT m BlockData -scottyBlockTime (GetBlockTime (TimeParam t) (NoTx noTx)) = - maybe (S.raise ThingNotFound) (return . pruneTx noTx) =<< blockAtOrBefore t +scottyBlockTime :: (MonadUnliftIO m, MonadLoggerIO m) + => GetBlockTime -> WebT m BlockData +scottyBlockTime (GetBlockTime (TimeParam t) (NoTx noTx)) = do + ch <- lift $ asks (storeChain . webStore) + m <- blockAtOrBefore ch t + maybe (S.raise ThingNotFound) (return . pruneTx noTx) m -scottyBlockTimeRaw :: - (MonadUnliftIO m, MonadLoggerIO m) - => GetBlockTimeRaw - -> WebT m (RawResult H.Block) +scottyBlockMTP :: (MonadUnliftIO m, MonadLoggerIO m) + => GetBlockMTP -> WebT m BlockData +scottyBlockMTP (GetBlockMTP (TimeParam t) (NoTx noTx)) = do + ch <- lift $ asks (storeChain . webStore) + m <- blockAtOrAfterMTP ch t + maybe (S.raise ThingNotFound) (return . pruneTx noTx) m + +scottyBlockTimeRaw :: (MonadUnliftIO m, MonadLoggerIO m) + => GetBlockTimeRaw -> WebT m (RawResult H.Block) scottyBlockTimeRaw (GetBlockTimeRaw (TimeParam t)) = do - b <- maybe (S.raise ThingNotFound) return =<< blockAtOrBefore t + ch <- lift $ asks (storeChain . webStore) + m <- blockAtOrBefore ch t + b <- maybe (S.raise ThingNotFound) return m refuseLargeBlock b RawResult <$> toRawBlock b +scottyBlockMTPRaw :: (MonadUnliftIO m, MonadLoggerIO m) + => GetBlockMTPRaw -> WebT m (RawResult H.Block) +scottyBlockMTPRaw (GetBlockMTPRaw (TimeParam t)) = do + ch <- lift $ asks (storeChain . webStore) + m <- blockAtOrAfterMTP ch t + b <- maybe (S.raise ThingNotFound) return m + refuseLargeBlock b + RawResult <$> toRawBlock b + -- GET Transactions -- scottyTx :: (MonadUnliftIO m, MonadLoggerIO m) => GetTx -> WebT m Transaction @@ -1037,7 +1065,8 @@ _ <- MaybeT $ getTxData (TxHash h) return $ AtTx (TxHash h) start_time q = do - b <- MaybeT $ blockAtOrBefore q + ch <- lift $ asks (storeChain . webStore) + b <- MaybeT $ blockAtOrBefore ch q let g = blockDataHeight b return $ AtBlock g