diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,23 +4,32 @@ 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.35.11 +## 0.55.0 ### Changed +- Always have a previous output object in Blockchain inputs. + +## 0.54.0 +### Added +- WebSocket support. +- Testnet4 support. + +## 0.53.11 +### Changed - Dummy version increase to signal upstream update of Haskoin Core. -## 0.35.10 +## 0.53.10 ### Fixed - Correct test that was reversed in previous version. -## 0.35.9 +## 0.53.9 ### Removed - Mempool is no longer synced by default to fix public Bitcoin Core regression. -## 0.35.8 +## 0.53.8 ### Changed - Put derivations stat inside database. -## 0.35.7 +## 0.53.7 ### Added - Added counters for database retrievals. - Added counter for xpub derivations. @@ -28,7 +37,7 @@ ### Changed - Removed some buggy or unnecessary stats. -## 0.35.6 +## 0.53.6 ### Changed - Improve web server statistics. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -13,9 +13,9 @@ - RESTful API with JSON and binary serialization. - High performance concurrent architecture. -## Quick Install with Nix Anywhere +## Install with Nix on any distribution -* Get [Nix](https://nixos.org/nix/). +* Get [Nix](https://nixos.org/nix/) ```sh nix-env --install stack @@ -25,12 +25,12 @@ ~/.local/bin/haskoin-store --help ``` -## Install on Ubuntu 20.04 or Debian 10 +## Install on Ubuntu or Debian * Get [Stack](https://haskellstack.org/) ```sh -apt install git libsecp256k1-dev librocksdb-dev pkg-config +apt install git zlib1g-dev libsecp256k1-dev librocksdb-dev pkg-config git clone https://github.com/haskoin/haskoin-store.git cd haskoin-store stack build --copy-bins @@ -39,8 +39,9 @@ ## Non-Haskell Dependencies +* [zlib](https://zlib.net/) * [libsecp256k1](https://github.com/Bitcoin-ABC/secp256k1) -* [RocksDB](https://github.com/facebook/rocksdb/) +* [RocksDB](https://github.com/facebook/rocksdb) ## API Documentation diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -21,7 +21,7 @@ import qualified Data.Text as T import Data.Word (Word32) import Haskoin (Network (..), allNets, bch, - bchRegTest, bchTest, btc, + bchRegTest, bchTest, bchTest4, btc, btcRegTest, btcTest, eitherToMaybe) import Haskoin.Node (withConnection) import Haskoin.Store (StoreConfig (..), WebConfig (..), @@ -54,8 +54,7 @@ { configDir :: !FilePath , configHost :: !String , configPort :: !Int - , configNetwork :: !Network - , configAsert :: !Word32 + , configNetwork :: !String , configDiscover :: !Bool , configPeers :: ![(String, Maybe Int)] , configVersion :: !Bool @@ -88,7 +87,6 @@ , configHost = defHost , configPort = defPort , configNetwork = defNetwork - , configAsert = defAsert , configDiscover = defDiscover , configPeers = defPeers , configVersion = False @@ -157,16 +155,11 @@ defEnv "PORT" 3000 readMaybe {-# NOINLINE defPort #-} -defNetwork :: Network +defNetwork :: String defNetwork = unsafePerformIO $ - defEnv "NET" bch (eitherToMaybe . networkReader) + defEnv "NET" "bch" pure {-# NOINLINE defNetwork #-} -defAsert :: Word32 -defAsert = unsafePerformIO $ - defEnv "ASERT" 0 readMaybe -{-# NOINLINE defAsert #-} - defRedisMin :: Int defRedisMin = unsafePerformIO $ defEnv "CACHE_MIN" 100 readMaybe @@ -335,19 +328,13 @@ <> showDefault <> value (configPort def) configNetwork <- - option (eitherReader networkReader) $ + strOption $ metavar netNames <> long "net" <> short 'n' <> 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" @@ -429,14 +416,14 @@ option auto $ metavar "SECONDS" <> long "block-timeout" - <> help "Last block mined health timeout (0 = inf)" + <> help "Last block mined health timeout" <> showDefault <> value (blockTimeout (configWebTimeouts def)) txTimeout <- option auto $ metavar "SECONDS" <> long "tx-timeout" - <> help "Last tx recived health timeout (0 = inf)" + <> help "Last tx recived health timeout" <> showDefault <> value (txTimeout (configWebTimeouts def)) configPeerTimeout <- @@ -563,6 +550,7 @@ | s == getNetworkName btcRegTest = Right btcRegTest | s == getNetworkName bch = Right bch | s == getNetworkName bchTest = Right bchTest + | s == getNetworkName bchTest4 = Right bchTest4 | s == getNetworkName bchRegTest = Right bchRegTest | otherwise = Left "Network name invalid" @@ -600,8 +588,7 @@ run :: Config -> IO () run Config { configHost = host , configPort = port - , configNetwork = net - , configAsert = asert + , configNetwork = net_str , configDiscover = disc , configPeers = peers , configDir = db_dir @@ -629,17 +616,20 @@ , configWebPriceGet = wpget } = runStderrLoggingT . filterLogger l . with_stats $ \stats -> do + net <- case networkReader net_str of + Right n -> return n + Left e -> error e $(logInfoS) "Main" $ - "Creating working directory if not found: " <> cs wd - createDirectoryIfMissing True wd + "Creating working directory if not found: " <> cs (wd net) + createDirectoryIfMissing True (wd net) let scfg = StoreConfig { storeConfMaxPeers = maxpeers , storeConfInitPeers = map (second (fromMaybe (getDefaultPort net))) peers , storeConfDiscover = disc - , storeConfDB = wd "db" - , storeConfNetwork = net' + , storeConfDB = wd net "db" + , storeConfNetwork = net , storeConfCache = if redis then Just redisurl @@ -686,9 +676,7 @@ (T.pack statsdpfx) (go . Just) | otherwise = go Nothing - net' | asert == 0 = net - | otherwise = net { getAsertActivationTime = Just asert } l _ lvl | deb = True | otherwise = LevelInfo <= lvl - wd = db_dir getNetworkName net' + wd net = db_dir getNetworkName net diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -3,11 +3,9 @@ -- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack --- --- hash: 7cff24e5b6ce01f7b47d7ce31d0eda998fdbe9b56ad028e075dec93d0fe2bd31 name: haskoin-store -version: 0.53.11 +version: 0.55.0 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -60,9 +58,9 @@ , ekg-statsd >=0.2.5 , foldl >=1.4.10 , hashable >=1.3.0.0 - , haskoin-core >=0.20.4 + , haskoin-core >=0.21.0 , haskoin-node >=0.17.0 - , haskoin-store-data ==0.53.11 + , haskoin-store-data ==0.55.0 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1 @@ -85,7 +83,9 @@ , vault >=0.3.1.5 , wai >=3.2.2.1 , wai-extra >=3.1.6 + , wai-websockets >=3.0.1.2 , warp >=3.3.10 + , websockets >=0.12.4 , wreq >=0.5.3.2 default-language: Haskell2010 @@ -113,10 +113,10 @@ , filepath , foldl >=1.4.10 , hashable >=1.3.0.0 - , haskoin-core >=0.20.4 + , haskoin-core >=0.21.0 , haskoin-node >=0.17.0 , haskoin-store - , haskoin-store-data ==0.53.11 + , haskoin-store-data ==0.55.0 , hedis >=0.12.13 , http-types >=0.12.3 , lens >=4.18.1 @@ -140,7 +140,9 @@ , vault >=0.3.1.5 , wai >=3.2.2.1 , wai-extra >=3.1.6 + , wai-websockets >=3.0.1.2 , warp >=3.3.10 + , websockets >=0.12.4 , wreq >=0.5.3.2 default-language: Haskell2010 @@ -172,10 +174,10 @@ , ekg-statsd >=0.2.5 , foldl >=1.4.10 , hashable >=1.3.0.0 - , haskoin-core >=0.20.4 + , haskoin-core >=0.21.0 , haskoin-node >=0.17.0 , haskoin-store - , haskoin-store-data ==0.53.11 + , haskoin-store-data ==0.55.0 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3 @@ -199,7 +201,9 @@ , vault >=0.3.1.5 , wai >=3.2.2.1 , wai-extra >=3.1.6 + , wai-websockets >=3.0.1.2 , warp >=3.3.10 + , websockets >=0.12.4 , wreq >=0.5.3.2 default-language: Haskell2010 build-tool-depends: hspec-discover:hspec-discover diff --git a/src/Haskoin/Store/BlockStore.hs b/src/Haskoin/Store/BlockStore.hs --- a/src/Haskoin/Store/BlockStore.hs +++ b/src/Haskoin/Store/BlockStore.hs @@ -610,29 +610,29 @@ => BlockStore -> UTCTime -> Tx - -> WriterT m Bool + -> WriterT m (Maybe (HashSet TxHash)) importMempoolTx block_read time tx = catchError new_mempool_tx handle_error where tx_hash = txHash tx handle_error Orphan = do newOrphanTx block_read time tx - return False - handle_error _ = return False + return Nothing + handle_error _ = return Nothing seconds = floor (utcTimeToPOSIXSeconds time) new_mempool_tx = newMempoolTx tx seconds >>= \case - True -> do + Just set -> do $(logInfoS) "BlockStore" $ "Import tx " <> txHashToHex (txHash tx) <> ": OK" fulfillOrphans block_read tx_hash - return True - False -> do + return (Just set) + Nothing -> do $(logDebugS) "BlockStore" $ "Import tx " <> txHashToHex (txHash tx) <> ": Already imported" - return False + return Nothing processMempool :: MonadLoggerIO m => BlockT m () processMempool = guardMempool $ do @@ -645,8 +645,8 @@ block_read (pendingTxTime p) (pendingTx p) >>= \case - True -> return $ Just (txHash (pendingTx p)) - False -> return Nothing + Just set -> return $ Just (txHash (pendingTx p), set) + Nothing -> return Nothing import_txs block_read txs = let r = mapM (run_import block_read) txs in runImport r >>= \case @@ -657,8 +657,9 @@ "Error processing mempool: " <> cs (show e) throwIO e success = mapM_ notify - notify txid = do + notify (txid, set) = do listener <- asks (blockConfListener . myConfig) + mapM ((`publish` listener) . StoreMempoolDelete) (HashSet.toList set) publish (StoreMempoolNew txid) listener processTxs :: 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 @@ -328,6 +328,7 @@ data StoreEvent = StoreBestBlock !BlockHash | StoreMempoolNew !TxHash + | StoreMempoolDelete !TxHash | StorePeerConnected !Peer | StorePeerDisconnected !Peer | StorePeerPong !Peer !Word64 diff --git a/src/Haskoin/Store/Logic.hs b/src/Haskoin/Store/Logic.hs --- a/src/Haskoin/Store/Logic.hs +++ b/src/Haskoin/Store/Logic.hs @@ -22,6 +22,7 @@ logErrorS) import qualified Data.ByteString as B import Data.Either (rights) +import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import qualified Data.IntMap.Strict as I import Data.List (nub) @@ -91,17 +92,20 @@ $(logDebugS) "BlockStore" "Importing Genesis block" importBlock (genesisBlock net) (genesisNode net) -newMempoolTx :: MonadImport m => Tx -> UnixTime -> m Bool +-- | If it returns 'Nothing', then transaction was not imported because it +-- already exists. Otherwise tranasction was imported successfully. Any deleted +-- transactions will be returned in the set (RBF only). +newMempoolTx :: MonadImport m => Tx -> UnixTime -> m (Maybe (HashSet TxHash)) newMempoolTx tx w = getActiveTxData (txHash tx) >>= \case Just _ -> - return False + return Nothing Nothing -> do - freeOutputs True True tx + txids <- freeOutputs True True tx rbf <- isRBF (MemRef w) tx checkNewTx tx importTx (MemRef w) w rbf tx - return True + return (Just txids) bestBlockData :: MonadImport m => m BlockData bestBlockData = do @@ -385,13 +389,15 @@ => Bool -- ^ only delete transaction if unconfirmed -> Bool -- ^ only delete RBF -> Tx - -> m () -freeOutputs memonly rbfcheck tx = - forM_ (prevOuts tx) $ \op -> - getUnspent op >>= \u -> when (isNothing u) $ - getSpender op >>= \p -> forM_ p $ \s -> - unless (spenderHash s == txHash tx) $ - deleteTx memonly rbfcheck (spenderHash s) + -> m (HashSet TxHash) +freeOutputs memonly rbfcheck tx = do + let prevs = prevOuts tx + unspents <- mapM getUnspent prevs + let spents = map fst $ filter (isNothing . snd) $ zip prevs unspents + spndrs <- catMaybes <$> mapM getSpender spents + let txids = HashSet.fromList $ filter (/= txHash tx) $ map spenderHash spndrs + mapM (deleteTx memonly rbfcheck) $ HashSet.toList txids + return txids deleteConfirmedTx :: MonadImport m => TxHash -> m () deleteConfirmedTx = deleteTx False False diff --git a/src/Haskoin/Store/Manager.hs b/src/Haskoin/Store/Manager.hs --- a/src/Haskoin/Store/Manager.hs +++ b/src/Haskoin/Store/Manager.hs @@ -91,7 +91,7 @@ -- ^ do not index new mempool transactions , storeConfWipeMempool :: !Bool -- ^ wipe mempool when starting - , storeConfSyncMempool :: !Bool + , storeConfSyncMempool :: !Bool -- ^ sync mempool from peers , storeConfPeerTimeout :: !NominalDiffTime -- ^ disconnect peer if message not received for this many seconds 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} @@ -91,6 +90,7 @@ import Haskoin.Address import qualified Haskoin.Block as H import Haskoin.Constants +import Haskoin.Data import Haskoin.Keys import Haskoin.Network import Haskoin.Node (Chain, @@ -110,7 +110,8 @@ import Haskoin.Store.WebCommon import Haskoin.Transaction import Haskoin.Util -import NQE (Inbox, receive, +import NQE (Inbox, Publisher, + receive, withSubscription) import Network.HTTP.Types (Status (..), requestEntityTooLarge413, @@ -128,7 +129,16 @@ responseStatus) import Network.Wai.Handler.Warp (defaultSettings, setHost, setPort) +import Network.Wai.Handler.WebSockets (websocketsOr) import Network.Wai.Middleware.RequestSizeLimit +import Network.WebSockets (ServerApp, + acceptRequest, + defaultConnectionOptions, + pendingRequest, + rejectRequestWith, + requestPath, + sendTextData) +import qualified Network.WebSockets as WebSockets import qualified Network.Wreq as Wreq import System.IO.Unsafe (unsafeInterleaveIO) import qualified System.Metrics as Metrics @@ -342,6 +352,12 @@ d x = createStatDist ("web." <> x) s g x = Metrics.createGauge ("web." <> x) s +withGaugeIO :: MonadUnliftIO m => Metrics.Gauge -> m a -> m a +withGaugeIO g = + bracket_ + (liftIO $ Metrics.Gauge.inc g) + (liftIO $ Metrics.Gauge.dec g) + withGaugeIncrease :: MonadUnliftIO m => (WebMetrics -> Metrics.Gauge) -> WebT m a @@ -350,15 +366,8 @@ lift (asks webMetrics) >>= \case Nothing -> go Just m -> do - s <- liftWith $ \run -> - bracket_ - (start m) - (end m) - (run go) + s <- liftWith $ \run -> withGaugeIO (gf m) (run go) restoreT $ return s - where - start m = liftIO $ Metrics.Gauge.inc (gf m) - end m = liftIO $ Metrics.Gauge.dec (gf m) setMetrics :: MonadUnliftIO m => (WebMetrics -> StatDist) @@ -458,6 +467,7 @@ reqLogger <- logIt metrics runner <- askRunInIO S.scottyOptsT opts (runner . (`runReaderT` st)) $ do + S.middleware (webSocketEvents st) S.middleware reqLogger S.middleware (reqSizeLimit maxLimitBody) S.defaultHandler defHandler @@ -510,7 +520,7 @@ req <- S.request mM <- case V.lookup (statKey m) (vault req) of Nothing -> return Nothing - Just t -> readTVarIO t + Just t -> readTVarIO t let status = errStatus err if | statusIsClientError status -> liftIO $ do @@ -1218,6 +1228,31 @@ ths <- map snd . applyLimits l <$> getMempool return ths + +webSocketEvents :: WebState -> Middleware +webSocketEvents s = + websocketsOr defaultConnectionOptions events + where + pub = (storePublisher . webStore . webConfig) s + gauge = statEvents <$> webMetrics s + events pending = withSubscription pub $ \sub -> do + let path = requestPath $ pendingRequest pending + if path == "/events" + then do + conn <- acceptRequest pending + forever $ receiveEvent sub >>= \case + Nothing -> return () + Just event -> sendTextData conn (A.encode event) + else + rejectRequestWith + pending + WebSockets.defaultRejectRequest + { WebSockets.rejectBody = L.toStrict $ A.encode ThingNotFound + , WebSockets.rejectCode = 404 + , WebSockets.rejectMessage = "Not Found" + , WebSockets.rejectHeaders = [("Content-Type", "application/json")] + } + scottyEvents :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m () scottyEvents = withGaugeIncrease statEvents $ do @@ -1240,9 +1275,10 @@ se <- receive sub return $ case se of - StoreBestBlock b -> Just (EventBlock b) - StoreMempoolNew t -> Just (EventTx t) - _ -> Nothing + StoreBestBlock b -> Just (EventBlock b) + StoreMempoolNew t -> Just (EventTx t) + StoreMempoolDelete t -> Just (EventTx t) + _ -> Nothing -- GET Address Transactions -- @@ -1429,7 +1465,7 @@ if T.null p then return HashSet.empty else case parseBinfoAddr net p of - Nothing -> raise (UserError "invalid active address") + Nothing -> raise (UserError "invalid address") Just xs -> return $ HashSet.fromList xs getBinfoActive :: MonadIO m @@ -1556,7 +1592,7 @@ addr_c a = streamThings (getAddressTxs a) (Just txRefHash) def{limit = 50} binfo_tx b = toBinfoTx numtxid abook prune b compute_bal_change BinfoTx{..} = - let ins = mapMaybe getBinfoTxInputPrevOut getBinfoTxInputs + let ins = map getBinfoTxInputPrevOut getBinfoTxInputs out = getBinfoTxOutputs f b BinfoTxOutput{..} = let val = fromIntegral getBinfoTxOutputValue @@ -2049,10 +2085,11 @@ binfoShortBalReceived = balanceTotalReceived } get_addr_balance net cashaddr a = - let net' = if | cashaddr -> net - | net == bch -> btc - | net == bchTest -> btcTest - | otherwise -> net + let net' = if | cashaddr -> net + | net == bch -> btc + | net == bchTest -> btcTest + | net == bchTest4 -> btcTest + | otherwise -> net in case addrToText net' a of Nothing -> return Nothing Just a' -> getBalance a >>= \case @@ -2392,9 +2429,7 @@ -> WebT m [PeerInformation] scottyPeers _ = do setMetrics statPeers - peers <- lift $ getPeersInformation =<< - asks (storeManager . webStore . webConfig) - return peers + lift $ getPeersInformation =<< asks (storeManager . webStore . webConfig) -- | Obtain information about connected peers from peer manager process. getPeersInformation @@ -2461,7 +2496,9 @@ return TimeHealth {..} where ch = storeChain webStore - to = if webNoMempool then blockTimeout webTimeouts else txTimeout webTimeouts + to = if webNoMempool + then blockTimeout webTimeouts + else txTimeout webTimeouts pendingTxsHealthCheck :: (MonadUnliftIO m, MonadLoggerIO m, StoreReadBase m) => WebConfig -> m MaxHealth