haskoin-node 0.9.19 → 0.9.20
raw patch · 5 files changed
+61/−204 lines, 5 files
Files
- CHANGELOG.md +5/−0
- haskoin-node.cabal +2/−2
- src/Network/Haskoin/Node/Chain.hs +14/−77
- src/Network/Haskoin/Node/Manager.hs +33/−101
- src/Network/Haskoin/Node/Peer.hs +7/−24
CHANGELOG.md view
@@ -4,6 +4,11 @@ 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.9.20+### Changed+- Better log messages.+- Less verbose debug logging.+ ## 0.9.19 ### Changed - Better log messages.
haskoin-node.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 917e10b5d9a35cb85510666d9e1af2a97ae9b7390c2456c2cb141f7fdda4c10d+-- hash: 3105ca1d000db59e33f68ffd6a2ed2990da90f79557b1a3f38798d486912a3b9 name: haskoin-node-version: 0.9.19+version: 0.9.20 synopsis: Haskoin Node P2P library for Bitcoin and Bitcoin Cash description: Bitcoin and Bitcoin Cash peer-to-peer protocol library featuring headers-first synchronisation. category: Bitcoin, Finance, Network
src/Network/Haskoin/Node/Chain.hs view
@@ -24,8 +24,8 @@ import Control.Monad (forever, guard, void, when) import Control.Monad.Except (runExceptT, throwError)-import Control.Monad.Logger (MonadLoggerIO, logDebugS,- logErrorS, logInfoS, logWarnS)+import Control.Monad.Logger (MonadLoggerIO, logErrorS,+ logInfoS) import Control.Monad.Reader (MonadReader, asks, runReaderT) import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)@@ -45,8 +45,7 @@ import Haskoin (BlockHash, BlockHeader (..), BlockHeaders (..), BlockNode (..), GetHeaders (..), Message (..),- Network, Timestamp,- blockHashToHex, blockLocator,+ Network, Timestamp, blockLocator, connectBlocks, genesisNode, getAncestor, headerHash, splitPoint)@@ -77,11 +76,7 @@ chain cfg inbox = do st <- newTVarIO- ChainState- { chainSyncing = Nothing- , mySynced = False- , newPeers = []- }+ ChainState {chainSyncing = Nothing, mySynced = False, newPeers = []} let rd = ChainReader {myReader = cfg, myChainDB = db, chainState = st} withSyncLoop ch $ run `runReaderT` rd where@@ -89,13 +84,9 @@ db = chainConfDB cfg ch = inboxToMailbox inbox run = do- $(logDebugS) "Chain" "Initializing" initChainDB net getBestBlockHeader >>= chainEvent . ChainBestBlock- $(logInfoS) "Chain" "Initialization complete"- forever $ do- $(logDebugS) "Chain" "Awaiting message"- receive inbox >>= chainMessage+ forever (receive inbox >>= chainMessage) chainEvent :: MonadChain m => ChainEvent -> m () chainEvent e = do@@ -103,10 +94,10 @@ case e of ChainBestBlock b -> $(logInfoS) "Chain" $- "Best block header at height " <> cs (show (nodeHeight b))+ "Best block header at height: " <> cs (show (nodeHeight b)) ChainSynced b -> $(logInfoS) "Chain" $- "Headers now synced at height " <> cs (show (nodeHeight b))+ "Headers now in sync at height: " <> cs (show (nodeHeight b)) atomically $ l e processHeaders ::@@ -114,7 +105,7 @@ processHeaders p hs = void . runMaybeT $ do net <- chainConfNetwork <$> asks myReader- $(logDebugS) "Chain" $+ $(logInfoS) "Chain" $ "Importing " <> cs (show (length hs)) <> " headers" now <- round <$> liftIO getPOSIXTime pbest <- getBestBlockHeader@@ -129,29 +120,21 @@ ChainBestBlock best if done then do- $(logDebugS)- "Chain"- "Finished importing headers from syncing peer" MSendHeaders `sendMessage` p finishPeer p syncNewPeer syncNotif else do- $(logDebugS)- "Chain"- "Continuing importing headers from syncing peer" syncPeer p syncNewPeer :: MonadChain m => m () syncNewPeer = getSyncingPeer >>= \case Nothing -> do- $(logDebugS) "Chain" "Getting next peer to sync from" nextPeer >>= \case- Nothing ->- $(logDebugS) "Chain" "Finished syncing against all peers"+ Nothing -> return () Just p -> syncPeer p- Just _ -> $(logDebugS) "Chain" "Already syncing against a peer"+ Just _ -> return () syncNotif :: MonadChain m => m () syncNotif =@@ -160,7 +143,6 @@ syncPeer :: MonadChain m => Peer -> m () syncPeer p = do- $(logDebugS) "Chain" "Syncing headers against selected peer" bb <- chainSyncingPeer >>= \case Just ChainSync {chainSyncPeer = p', chainHighest = Just g}@@ -168,72 +150,30 @@ _ -> getBestBlockHeader now <- round <$> liftIO getPOSIXTime gh <- syncHeaders now bb p- $(logDebugS) "Chain" $- "Requesting headers from syncing peer for chain head at height: " <>- cs (show (nodeHeight bb)) MGetHeaders gh `sendMessage` p chainMessage :: MonadChain m => ChainMessage -> m ()-chainMessage (ChainGetBest reply) = do- $(logDebugS) "Chain" "Responding to request for best block header"- getBestBlockHeader >>= \bh -> do- $(logDebugS) "Chain" $- "Best block header: " <> blockHashToHex (headerHash (nodeHeader bh)) <>- " at height " <>- cs (show (nodeHeight bh))- atomically $ reply bh-chainMessage (ChainHeaders p hs) = do- $(logDebugS) "Chain" $ "Processing " <> cs (show (length hs)) <> " headers"- processHeaders p hs-chainMessage (ChainPeerConnected p a) = do- $(logDebugS) "Chain" $ "Adding new peer to sync queue: " <> cs (show a)+chainMessage (ChainGetBest reply) = getBestBlockHeader >>= atomically . reply+chainMessage (ChainHeaders p hs) = processHeaders p hs+chainMessage (ChainPeerConnected p _) = do addPeer p syncNewPeer-chainMessage (ChainPeerDisconnected p a) = do- $(logWarnS) "Chain" $ "Removing a peer from sync queue: " <> cs (show a)+chainMessage (ChainPeerDisconnected p _) = do finishPeer p syncNewPeer chainMessage (ChainGetAncestor h n reply) = do- $(logDebugS) "Chain" $- "Responding to request for ancestor at height " <> cs (show h) <>- " to block: " <>- blockHashToHex (headerHash (nodeHeader n)) a <- getAncestor h n atomically $ reply a- case a of- Just b ->- $(logDebugS) "Chain" $- "Ancestor is: " <> blockHashToHex (headerHash (nodeHeader b))- Nothing -> $(logDebugS) "Chain" "Ancestor not found" chainMessage (ChainGetSplit l r reply) = do- $(logDebugS) "Chain" $- "Responding to request for split point between blocks " <>- blockHashToHex (headerHash (nodeHeader l)) <>- " & " <>- blockHashToHex (headerHash (nodeHeader r)) s <- splitPoint l r atomically $ reply s- $(logDebugS) "Chain" $- "Split block is: " <> blockHashToHex (headerHash (nodeHeader s)) chainMessage (ChainGetBlock h reply) = do- $(logDebugS) "Chain" $- "Responding to request for block: " <> blockHashToHex h m <- getBlockHeader h atomically $ reply m- case m of- Nothing ->- $(logDebugS) "Chain" $ "Block not found: " <> blockHashToHex h- Just b ->- $(logDebugS) "Chain" $- "Block found at height " <> cs (show (nodeHeight b)) chainMessage (ChainIsSynced reply) = do s <- isSynced- if s- then $(logDebugS) "Chain" "Chain is in sync"- else $(logDebugS) "Chain" "Chain is NOT in sync" atomically $ reply s chainMessage ChainPing = do- $(logDebugS) "Chain" "Housekeeping..." ChainConfig {chainConfTimeout = to} <- asks myReader now <- round <$> liftIO getPOSIXTime chainSyncingPeer >>= \case@@ -251,9 +191,6 @@ forever $ do threadDelay =<< liftIO (randomRIO (2 * 1000 * 1000, 20 * 1000 * 1000))- $(logDebugS)- "ChainSyncLoop"- "Ping chain for housekeeping" ChainPing `send` ch -- | Version of the database.
src/Network/Haskoin/Node/Manager.hs view
@@ -25,8 +25,7 @@ import Control.Monad.Except (ExceptT (..), runExceptT, throwError) import Control.Monad.Logger (MonadLogger, MonadLoggerIO,- logDebugS, logErrorS, logInfoS,- logWarnS)+ logErrorS, logInfoS, logWarnS) import Control.Monad.Reader (MonadReader, asks, runReaderT) import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)@@ -44,10 +43,9 @@ import Haskoin (Addr (..), BlockHeight, Message (..), Network (..), NetworkAddress (..), Ping (..),- Pong (..), VarString (..),- Version (..), commandToString,- hostToSockAddr, msgType,- nodeNetwork, sockToHostAddress)+ Pong (..), Version (..),+ hostToSockAddr, nodeNetwork,+ sockToHostAddress) import Network.Haskoin.Node.Common (HostPort, Manager, ManagerConfig (..), ManagerMessage (..),@@ -111,22 +109,17 @@ where mgr = inboxToMailbox inbox go = do- $(logDebugS) "Manager" "Initializing" putBestBlock <=< receiveMatch inbox $ \case ManagerBestBlock b -> Just b _ -> Nothing- $(logDebugS) "Manager" "Initialization complete" withConnectLoop mgr $ forever $ do- $(logDebugS) "Manager" "Awaiting message" m <- receive inbox managerMessage m f (a, mex) = ManagerPeerDied a mex `sendSTM` mgr putBestBlock :: MonadManager m => BlockHeight -> m ()-putBestBlock bb = do- $(logDebugS) "Manager" $ "Best block at height " <> cs (show bb)- asks myBestBlock >>= \b -> atomically $ writeTVar b bb+putBestBlock bb = asks myBestBlock >>= \b -> atomically $ writeTVar b bb getBestBlock :: MonadManager m => m BlockHeight getBestBlock = asks myBestBlock >>= readTVarIO@@ -141,22 +134,16 @@ loadStaticPeers :: (MonadUnliftIO m, MonadManager m) => m () loadStaticPeers = do- $(logDebugS) "Manager" "Loading static peers" xs <- asks (mgrConfPeers . myConfig) mapM_ newPeer =<< concat <$> mapM toSockAddr xs loadNetSeeds :: (MonadUnliftIO m, MonadManager m) => m () loadNetSeeds = asks (mgrConfDiscover . myConfig) >>= \discover ->- if discover- then do- net <- getNetwork- $(logDebugS) "Manager" "Loading network seeds"- ss <- concat <$> mapM toSockAddr (networkSeeds net)- $(logDebugS) "Manager" $- "Adding " <> cs (show (length ss)) <> " seed peers"- mapM_ newPeer ss- else $(logDebugS) "Manager" "Peer discovery disabled"+ when discover $ do+ net <- getNetwork+ ss <- concat <$> mapM toSockAddr (networkSeeds net)+ mapM_ newPeer ss logConnectedPeers :: MonadManager m => m () logConnectedPeers = do@@ -183,14 +170,10 @@ s <- atomically $ peerString b p e <- runExceptT $ do- let ua = getVarString $ userAgent v- $(logDebugS) "Manager" $- "Got version from peer " <> s <> ": " <> cs ua o <- ExceptT . atomically $ setPeerVersion b p v when (onlinePeerConnected o) $ announcePeer p case e of Right () -> do- $(logDebugS) "Manager" $ "Version accepted for peer " <> s MVerAck `sendMessage` p Left x -> do $(logErrorS) "Manager" $@@ -201,89 +184,50 @@ b <- asks onlinePeers s <- atomically $ peerString b p atomically (setPeerVerAck b p) >>= \case- Just o -> do- $(logDebugS) "Manager" $ "Received verack from peer: " <> s- when (onlinePeerConnected o) $ announcePeer p+ Just o -> when (onlinePeerConnected o) $ announcePeer p Nothing -> do $(logErrorS) "Manager" $ "Received verack from unknown peer: " <> s killPeer UnknownPeer p -managerMessage (ManagerPeerMessage p (MAddr (Addr nas))) = do- b <- asks onlinePeers- s <- atomically $ peerString b p- let n = length nas- $(logDebugS) "Manager" $- "Received " <> cs (show n) <> " addresses from peer " <> s+managerMessage (ManagerPeerMessage _ (MAddr (Addr nas))) = asks (mgrConfDiscover . myConfig) >>= \discover ->- if discover- then do- let sas = map (hostToSockAddr . naAddress . snd) nas- forM_ sas newPeer- else $(logDebugS)- "Manager"- "Ignoring new peers since peer discovery disabled"+ when discover $ do+ let sas = map (hostToSockAddr . naAddress . snd) nas+ $(logInfoS) "Manager" $+ "Adding " <> cs (show (length sas)) <> " new peers"+ forM_ sas newPeer managerMessage (ManagerPeerMessage p m@(MPong (Pong n))) = do now <- liftIO getCurrentTime b <- asks onlinePeers- s <- atomically $ peerString b p atomically (gotPong b n now p) >>= \case- Nothing -> do- $(logDebugS) "Manager" $- "Forwarding pong " <> cs (show n) <> " from " <> s- forwardMessage p m- Just d -> do- let ms = fromRational . toRational $ d * 1000 :: Double- $(logDebugS) "Manager" $- "Ping roundtrip to " <> s <> ": " <> cs (show ms) <> " ms"+ Nothing -> forwardMessage p m+ Just _ -> return () -managerMessage (ManagerPeerMessage p (MPing (Ping n))) = do- b <- asks onlinePeers- s <- atomically $ peerString b p- $(logDebugS) "Manager" $- "Responding to ping " <> cs (show n) <> " from " <> s+managerMessage (ManagerPeerMessage p (MPing (Ping n))) = MPong (Pong n) `sendMessage` p -managerMessage (ManagerPeerMessage p m) = do- b <- asks onlinePeers- s <- atomically $ peerString b p- let cmd = commandToString $ msgType m- $(logDebugS) "Manager" $- "Forwarding message " <> cs cmd <> " from peer " <> s- forwardMessage p m+managerMessage (ManagerPeerMessage p m) = forwardMessage p m -managerMessage (ManagerBestBlock h) = do- $(logDebugS) "Manager" $ "Setting best block at height " <> cs (show h)- putBestBlock h+managerMessage (ManagerBestBlock h) = putBestBlock h managerMessage ManagerConnect = do l <- length <$> getConnectedPeers x <- asks (mgrConfMaxPeers . myConfig)- if l < x- then getNewPeer >>= \case- Nothing ->- $(logDebugS) "Manager" "No other peers available to connect"- Just sa -> connectPeer sa- else $(logDebugS) "Manager" "Enough peers connected"+ when (l < x) $+ getNewPeer >>= \case+ Nothing -> return ()+ Just sa -> connectPeer sa managerMessage (ManagerPeerDied a e) = processPeerOffline a e managerMessage (ManagerGetPeers reply) = do- $(logDebugS) "Manager" "Responding to request for connected peers" ps <- getConnectedPeers- $(logDebugS) "Manager" $- "There are " <> cs (show (length ps)) <> " connected peers" atomically $ reply ps managerMessage (ManagerGetOnlinePeer p reply) = do- $(logDebugS) "Manager" "Responding to request for particular peer" b <- asks onlinePeers- m <- atomically $ findPeer b p >>= \o -> reply o >> return o- case m of- Nothing -> $(logDebugS) "Manager" "Requested peer not found"- Just o ->- $(logDebugS) "Manager" $- "Peer found at address: " <> cs (show (onlinePeerAddress o))+ atomically $ findPeer b p >>= reply managerMessage (ManagerCheckPeer p) = checkPeer p @@ -292,7 +236,6 @@ ManagerConfig {mgrConfTimeout = to} <- asks myConfig b <- asks onlinePeers s <- atomically $ peerString b p- $(logDebugS) "Manager" $ "Checking on peer " <> s atomically (findPeer b p) >>= \case Nothing -> return () Just o -> do@@ -302,12 +245,10 @@ Nothing -> pingPeer p Just t -> do now <- liftIO getCurrentTime- if diffUTCTime now t > fromIntegral to- then do- $(logErrorS) "Manager" $- "Peer " <> s <> " did not respond ping on time"- killPeer PeerTimeout p- else $(logDebugS) "Manager" $ "peer " <> s <> " awaiting pong"+ when (diffUTCTime now t > fromIntegral to) $ do+ $(logErrorS) "Manager" $+ "Peer " <> s <> " did not respond ping on time"+ killPeer PeerTimeout p pingPeer :: MonadManager m => Peer -> m () pingPeer p = do@@ -320,12 +261,8 @@ n <- liftIO randomIO now <- liftIO getCurrentTime atomically (setPeerPing b n now p)- $(logDebugS) "Manager" $- "Sending ping " <> cs (show n) <> " to peer " <> s MPing (Ping n) `sendMessage` p- | otherwise ->- $(logWarnS) "Manager" $- "Will not ping peer " <> s <> " until handshake complete"+ | otherwise -> return () processPeerOffline :: MonadManager m => Child -> Maybe SomeException -> m () processPeerOffline a e = do@@ -368,9 +305,7 @@ managerEvent $ PeerConnected p a logConnectedPeers managerCheck p mgr- Just OnlinePeer {onlinePeerConnected = False} ->- $(logErrorS) "Manager" $- "Not announcing because not handshaken: " <> s+ Just OnlinePeer {onlinePeerConnected = False} -> return () Nothing -> $(logErrorS) "Manager" "Will not announce unknown peer" getNewPeer :: (MonadUnliftIO m, MonadManager m) => m (Maybe SockAddr)@@ -439,14 +374,12 @@ -> Manager -> (Async a -> m a) -> m a-withPeerLoop sa p mgr = withAsync go+withPeerLoop _ p mgr = withAsync go where go = forever $ do threadDelay =<< liftIO (randomRIO (30 * 1000 * 1000, 90 * 1000 * 1000))- $(logDebugS) "Manager" $- "Ping manager for peer housekeeping: " <> cs (show sa) ManagerCheckPeer p `send` mgr withConnectLoop :: (MonadLogger m, MonadUnliftIO m) => Manager -> m a -> m a@@ -456,7 +389,6 @@ forever $ do threadDelay =<< liftIO (randomRIO (2 * 1000 * 1000, 10 * 1000 * 1000))- $(logDebugS) "Manager" "Ping manager for general housekeeping" ManagerConnect `send` mgr -- | Add a peer.
src/Network/Haskoin/Node/Peer.hs view
@@ -23,8 +23,7 @@ mapM_C, runConduit, takeCE, yield, (.|)) import Control.Monad (forever, when)-import Control.Monad.Logger (MonadLoggerIO, logDebugS,- logErrorS)+import Control.Monad.Logger (MonadLoggerIO, logErrorS) import Control.Monad.Reader (runReaderT) import Data.ByteString (ByteString) import qualified Data.ByteString as B@@ -34,8 +33,7 @@ import Data.Text (Text) import Network.Haskoin.Constants (Network) import Network.Haskoin.Network (Message, MessageHeader (..),- commandToString, getMessage,- msgType, putMessage)+ getMessage, putMessage) import Network.Haskoin.Node.Common (PeerConfig (..), PeerException (..), PeerMessage (..), withConnection)@@ -55,10 +53,8 @@ where a = peerConfAddress pc go = forever $ do- $(logDebugS) s "Awaiting message" receive inbox >>= dispatchMessage pc net = peerConfNetwork pc- s = peerString (peerConfAddress pc) peer_session ad = let ins = appSource ad ons = appSink ad@@ -72,20 +68,10 @@ -- | Internal function to dispatch peer messages. dispatchMessage :: MonadLoggerIO m => PeerConfig -> PeerMessage -> ConduitT i Message m ()-dispatchMessage cfg (SendMessage msg) = do- $(logDebugS) (peerString (peerConfAddress cfg)) $- "Outgoing: " <> cs (commandToString (msgType msg))- yield msg-dispatchMessage cfg (GetPublisher reply) = do- $(logDebugS)- (peerString (peerConfAddress cfg))- "Replying to publisher request"- atomically $ reply (peerConfListen cfg)-dispatchMessage cfg (KillPeer e) = do- $(logErrorS) s $ "Killing peer via mailbox request: " <> cs (show e)- throwIO e- where- s = peerString (peerConfAddress cfg)+dispatchMessage _ (SendMessage msg) = yield msg+dispatchMessage cfg (GetPublisher reply) =+ atomically (reply (peerConfListen cfg))+dispatchMessage _ (KillPeer e) = throwIO e -- | Internal conduit to parse messages coming from peer. inPeerConduit ::@@ -111,10 +97,7 @@ $(logErrorS) (peerString a) $ "Cannot decode payload: " <> cs (show e) throwIO CannotDecodePayload- Right msg -> do- $(logDebugS) (peerString a) $- "Incoming: " <> cs (commandToString (msgType msg))- yield msg+ Right msg -> yield msg -- | Outgoing peer conduit to serialize and send messages. outPeerConduit :: Monad m => Network -> ConduitT Message ByteString m ()