haskoin-node 0.2.0 → 0.3.0
raw patch · 9 files changed
+1261/−892 lines, 9 filesdep +esqueletodep +largeworddep +persistentdep −leveldb-haskelldep ~HUnitdep ~aesondep ~asyncnew-uploader
Dependencies added: esqueleto, largeword, persistent, persistent-sqlite, persistent-template, resource-pool, resourcet
Dependencies removed: leveldb-haskell
Dependency ranges changed: HUnit, aeson, async, binary, haskoin-core, lifted-async, stm-conduit, time
Files
- Network/Haskoin/Node/BlockChain.hs +168/−163
- Network/Haskoin/Node/HeaderTree.hs +529/−470
- Network/Haskoin/Node/HeaderTree/Model.hs +27/−0
- Network/Haskoin/Node/HeaderTree/Types.hs +27/−0
- Network/Haskoin/Node/Peer.hs +125/−112
- Network/Haskoin/Node/STM.hs +117/−113
- haskoin-node.cabal +24/−13
- stack.yaml +0/−14
- tests/Network/Haskoin/Node/Units.hs +244/−7
Network/Haskoin/Node/BlockChain.hs view
@@ -1,45 +1,46 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-} module Network.Haskoin.Node.BlockChain where -import System.Random (randomIO)--import Control.Monad (void, liftM, when, unless, forever, forM, forM_)-import Control.Monad.Trans (MonadIO, lift, liftIO)-import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp_)-import Control.Monad.Logger (MonadLogger, logInfo, logWarn, logDebug, logError)-import Control.Monad.Reader (ask, asks)-import Control.Concurrent (threadDelay)-import Control.Concurrent.STM.Lock (locked)-import qualified Control.Concurrent.STM.Lock as Lock (with)-import Control.Exception.Lifted (throw)-import Control.Concurrent.STM.TBMChan (readTBMChan, isEmptyTBMChan)-import Control.Concurrent.Async.Lifted- ( withAsync, link, waitAny, mapConcurrently )-import Control.Concurrent.STM- ( STM, atomically, readTVar, putTMVar, isEmptyTMVar- , takeTMVar, tryTakeTMVar, retry, tryReadTMVar- )--import Data.List (nub)-import Data.Text (pack)-import Data.Maybe (listToMaybe)-import Data.Time.Clock.POSIX (getPOSIXTime)-import Data.Unique (hashUnique)-import Data.Conduit (Source, yield)-import qualified Data.Sequence as S (length)-import qualified Data.ByteString.Char8 as C (unpack)-import Data.String.Conversions (cs)-import qualified Data.Map as M (keys, lookup, null, delete)-import Data.Word (Word32)--import Network.Haskoin.Node-import Network.Haskoin.Node.STM-import Network.Haskoin.Node.HeaderTree-import Network.Haskoin.Node.Peer-import Network.Haskoin.Transaction-import Network.Haskoin.Block+import Control.Concurrent (threadDelay)+import Control.Concurrent.Async.Lifted (link, mapConcurrently,+ waitAny, withAsync)+import Control.Concurrent.STM (STM, atomically, isEmptyTMVar,+ putTMVar, readTVar, retry,+ takeTMVar, tryReadTMVar,+ tryTakeTMVar)+import Control.Concurrent.STM.Lock (locked)+import qualified Control.Concurrent.STM.Lock as Lock (with)+import Control.Concurrent.STM.TBMChan (isEmptyTBMChan, readTBMChan)+import Control.Exception.Lifted (throw)+import Control.Monad (forM, forM_, forever, unless,+ void, when)+import Control.Monad.Logger (MonadLoggerIO, logDebug,+ logError, logInfo, logWarn)+import Control.Monad.Reader (ask, asks)+import Control.Monad.Trans (MonadIO, lift, liftIO)+import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp_)+import qualified Data.ByteString.Char8 as C (unpack)+import Data.Conduit (Source, yield)+import Data.List (nub)+import qualified Data.Map as M (delete, keys, lookup,+ null)+import Data.Maybe (listToMaybe)+import qualified Data.Sequence as S (length)+import Data.String.Conversions (cs)+import Data.Text (pack)+import Data.Time.Clock.POSIX (getPOSIXTime)+import Data.Unique (hashUnique)+import Data.Word (Word32)+import Network.Haskoin.Block+import Network.Haskoin.Node+import Network.Haskoin.Node.HeaderTree+import Network.Haskoin.Node.Peer+import Network.Haskoin.Node.STM+import Network.Haskoin.Transaction+import System.Random (randomIO) -startSPVNode :: (MonadLogger m, MonadIO m, MonadBaseControl IO m)+startSPVNode :: (MonadLoggerIO m, MonadBaseControl IO m) => [PeerHost] -> BloomFilter -> Int@@ -60,7 +61,7 @@ return () -- Source of all transaction broadcasts-txSource :: (MonadLogger m, MonadIO m, MonadBaseControl IO m)+txSource :: (MonadLoggerIO m, MonadBaseControl IO m) => Source (NodeT m) Tx txSource = do chan <- lift $ asks sharedTxChan@@ -73,7 +74,7 @@ yield tx >> txSource _ -> $(logError) "Tx channel closed unexpectedly" -handleGetData :: (MonadLogger m, MonadIO m, MonadBaseControl IO m)+handleGetData :: (MonadLoggerIO m, MonadBaseControl IO m) => (TxHash -> m (Maybe Tx)) -> NodeT m () handleGetData handler = forever $ do@@ -97,7 +98,7 @@ atomicallyNodeT $ trySendMessage pid $ MTx tx _ -> return () -broadcastTxs :: (MonadLogger m, MonadIO m, MonadBaseControl IO m)+broadcastTxs :: (MonadLoggerIO m, MonadBaseControl IO m) => [TxHash] -> NodeT m () broadcastTxs txids = do@@ -126,12 +127,11 @@ -- Wait for the next merkle batch to be available. This function will check for -- rescans. merkleDownload- :: (MonadLogger m, MonadIO m, MonadBaseControl IO m)- => BlockHash- -> Int- -> NodeT m ( BlockChainAction- , Source (NodeT m) (Either (MerkleBlock, MerkleTxs) Tx)- )+ :: (MonadLoggerIO m, MonadBaseControl IO m)+ => NodeBlock+ -> Word32+ -> NodeT m+ (BlockChainAction, Source (NodeT m) (Either (MerkleBlock, MerkleTxs) Tx)) merkleDownload bh batchSize = do -- Store the best block received from the wallet for information only. -- This will be displayed in `hw status`@@ -141,8 +141,8 @@ -- Wait either for a new block to arrive or a rescan to be triggered $(logDebug) "Waiting for a new block or a rescan..." resE <- atomicallyNodeT $ orElseNodeT- (liftM Left $ lift $ takeTMVar rescanTMVar)- (liftM (const $ Right ()) $ waitNewBlock bh)+ (fmap Left $ lift $ takeTMVar rescanTMVar)+ (const (Right ()) <$> waitNewBlock (nodeHash bh)) resM <- case resE of -- A rescan was triggered Left valE -> do@@ -154,7 +154,7 @@ [ "Rescan condition reached:", show newValE ] case newValE of Left ts -> tryMerkleDwnTimestamp ts batchSize- Right h -> tryMerkleDwnHeight h batchSize+ Right _ -> tryMerkleDwnHeight bh batchSize -- Continue download from a hash Right _ -> tryMerkleDwnBlock bh batchSize case resM of@@ -167,7 +167,7 @@ where waitRescan rescanTMVar valE = do resE <- atomicallyNodeT $ orElseNodeT- (liftM Left (lift $ takeTMVar rescanTMVar))+ (fmap Left (lift $ takeTMVar rescanTMVar)) (waitVal valE >> return (Right valE)) case resE of Left newValE -> waitRescan rescanTMVar newValE@@ -176,14 +176,14 @@ Left ts -> waitFastCatchup ts Right h -> waitHeight h -merkleCheckSync :: (MonadLogger m, MonadIO m, MonadBaseControl IO m)+merkleCheckSync :: (MonadLoggerIO m, MonadBaseControl IO m) => NodeT m () merkleCheckSync = do -- Check if we are synced (synced, mempool, ourHeight) <- atomicallyNodeT $ do synced <- areBlocksSynced when synced $ writeTVarS sharedMerklePeer Nothing- ourHeight <- liftM nodeHeaderHeight $ readTVarS sharedBestHeader+ ourHeight <- nodeBlockHeight <$> readTVarS sharedBestHeader mempool <- readTVarS sharedMempool return (synced, mempool, ourHeight) when synced $ do@@ -203,39 +203,40 @@ waitHeight height = do node <- readTVarS sharedBestHeader -- Check if we passed the timestamp condition- unless (height < nodeHeaderHeight node) $ lift retry+ unless (height < nodeBlockHeight node) $ lift retry -- Wait for headers to catch up to the given timestamp waitFastCatchup :: Timestamp -> NodeT STM () waitFastCatchup ts = do node <- readTVarS sharedBestHeader -- Check if we passed the timestamp condition- unless (ts < blockTimestamp (nodeHeader node)) $ lift retry+ unless (ts < blockTimestamp (nodeHeader node)) $+ lift retry -- Wait for a new block to be available for download waitNewBlock :: BlockHash -> NodeT STM () waitNewBlock bh = do node <- readTVarS sharedBestHeader -- We have more merkle blocks to download- unless (bh /= nodeBlockHash node) $ lift retry+ unless (bh /= nodeHash node) $+ lift retry tryMerkleDwnHeight- :: (MonadLogger m, MonadIO m, MonadBaseControl IO m)- => BlockHeight- -> Int- -> NodeT m ( Maybe ( BlockChainAction- , Source (NodeT m) (Either (MerkleBlock, MerkleTxs) Tx)- )- )-tryMerkleDwnHeight height batchSize = do+ :: (MonadLoggerIO m, MonadBaseControl IO m)+ => NodeBlock+ -> Word32+ -> NodeT m (Maybe (BlockChainAction,+ Source (NodeT m) (Either (MerkleBlock, MerkleTxs) Tx)))+tryMerkleDwnHeight block batchSize = do $(logInfo) $ pack $ unwords- [ "Requesting merkle blocks at height", show height+ [ "Requesting merkle blocks at height", show $ nodeBlockHeight block , "with batch size", show batchSize ] -- Request height - 1 as we want to start downloading at height- nodeM <- runHeaderTree $ getBlockHeaderByHeight $ height - 1+ nodeM <- runSqlNodeT $ getParentBlock block case nodeM of- Just BlockHeaderNode{..} -> tryMerkleDwnBlock nodeBlockHash batchSize+ Just bn ->+ tryMerkleDwnBlock bn batchSize _ -> do $(logDebug) $ pack $ unwords [ "Can't download merkle blocks."@@ -244,21 +245,20 @@ return Nothing tryMerkleDwnTimestamp- :: (MonadLogger m, MonadIO m, MonadBaseControl IO m)+ :: (MonadLoggerIO m, MonadBaseControl IO m) => Timestamp- -> Int- -> NodeT m ( Maybe ( BlockChainAction- , Source (NodeT m) (Either (MerkleBlock, MerkleTxs) Tx)- )- )+ -> Word32+ -> NodeT m (Maybe (BlockChainAction,+ Source (NodeT m) (Either (MerkleBlock, MerkleTxs) Tx))) tryMerkleDwnTimestamp ts batchSize = do $(logInfo) $ pack $ unwords [ "Requesting merkle blocks after timestamp", show ts , "with batch size", show batchSize ]- nodeM <- runHeaderTree $ getNodeAtTimestamp ts+ nodeM <- runSqlNodeT $ getBlockAfterTime ts case nodeM of- Just BlockHeaderNode{..} -> tryMerkleDwnBlock nodeBlockHash batchSize+ Just bh ->+ tryMerkleDwnBlock bh batchSize _ -> do $(logDebug) $ pack $ unwords [ "Can't download merkle blocks."@@ -267,45 +267,36 @@ return Nothing tryMerkleDwnBlock- :: (MonadLogger m, MonadIO m, MonadBaseControl IO m)- => BlockHash- -> Int- -> NodeT m ( Maybe ( BlockChainAction- , Source (NodeT m) (Either (MerkleBlock, MerkleTxs) Tx)- )- )+ :: (MonadLoggerIO m, MonadBaseControl IO m)+ => NodeBlock+ -> Word32+ -> NodeT m (Maybe (BlockChainAction,+ Source (NodeT m) (Either (MerkleBlock, MerkleTxs) Tx))) tryMerkleDwnBlock bh batchSize = do $(logDebug) $ pack $ unwords [ "Requesting merkle download from block"- , cs $ blockHashToHex bh, "and batch size", show batchSize+ , cs $ blockHashToHex (nodeHash bh)+ , "and batch size", show batchSize ]- --Get the list of merkle blocks to download from our headers- actionM <- runHeaderTree $ getNodeWindow bh batchSize- case actionM of- -- Nothing to download- Nothing -> do- $(logDebug) $ pack $ unwords- [ "No more merkle blocks available from block"- , cs $ blockHashToHex bh- ]+ -- Get the list of merkle blocks to download from our headers+ best <- atomicallyNodeT $ readTVarS sharedBestHeader+ action <- runSqlNodeT $ getBlockWindow best bh batchSize+ case actionNodes action of+ [] -> do+ $(logError) "BlockChainAction was empty" return Nothing- -- A batch of merkle blocks is available for download- Just action -> case actionNodes action of- [] -> do- $(logError) "BlockChainAction was empty"- return Nothing- ns -> do- -- Wait for a peer available for merkle download- (pid, PeerSession{..}) <- waitMerklePeer $- nodeHeaderHeight $ last ns+ ns -> do+ -- Wait for a peer available for merkle download+ (pid, PeerSession{..}) <- waitMerklePeer $+ nodeBlockHeight $ last ns - $(logDebug) $ formatPid pid peerSessionHost $ unwords- [ "Found merkle downloading peer with score"- , show peerSessionScore- ]+ $(logDebug) $ formatPid pid peerSessionHost $ unwords+ [ "Found merkle downloading peer with score"+ , show peerSessionScore+ ] - let source = peerMerkleDownload pid peerSessionHost action- return $ Just (action, source)+ let source = peerMerkleDownload pid peerSessionHost action+ return $ Just (action, source) where waitMerklePeer height = atomicallyNodeT $ do pidM <- readTVarS sharedHeaderPeer@@ -320,13 +311,13 @@ _ -> lift retry peerMerkleDownload- :: (MonadLogger m, MonadIO m, MonadBaseControl IO m)+ :: (MonadLoggerIO m, MonadBaseControl IO m) => PeerId -> PeerHost -> BlockChainAction -> Source (NodeT m) (Either (MerkleBlock, MerkleTxs) Tx) peerMerkleDownload pid ph action = do- let bids = map nodeBlockHash $ actionNodes action+ let bids = map nodeHash $ actionNodes action vs = map (InvVector InvMerkleBlock . getBlockHash) bids $(logInfo) $ formatPid pid ph $ unwords [ "Requesting", show $ length bids, "merkle block(s)" ]@@ -387,14 +378,14 @@ "Merkle channel closed unexpectedly" lift $ atomicallyNodeT $ writeTVarS sharedMerklePeer Nothing -processTickles :: (MonadLogger m, MonadIO m, MonadBaseControl IO m)+processTickles :: (MonadLoggerIO m, MonadBaseControl IO m) => NodeT m () processTickles = forever $ do $(logDebug) $ pack "Waiting for a block tickle ..." (pid, ph, tickle) <- atomicallyNodeT waitTickle $(logInfo) $ formatPid pid ph $ unwords [ "Received block tickle", cs $ blockHashToHex tickle ]- heightM <- runHeaderTree $ getBlockHeaderHeight tickle+ heightM <- fmap nodeBlockHeight <$> runSqlNodeT (getBlockByHash tickle) case heightM of Just height -> do $(logInfo) $ formatPid pid ph $ unwords@@ -408,7 +399,8 @@ , "is unknown. Requesting a peer header sync." ] peerHeaderSyncFull pid ph `catchAny` const (disconnectPeer pid ph)- newHeightM <- runHeaderTree $ getBlockHeaderHeight tickle+ newHeightM <-+ fmap nodeBlockHeight <$> runSqlNodeT (getBlockByHash tickle) case newHeightM of Just height -> do $(logInfo) $ formatPid pid ph $ unwords@@ -440,10 +432,10 @@ syncedHeight :: MonadIO m => NodeT m (Bool, Word32) syncedHeight = atomicallyNodeT $ do synced <- areHeadersSynced- ourHeight <- liftM nodeHeaderHeight $ readTVarS sharedBestHeader+ ourHeight <- nodeBlockHeight <$> readTVarS sharedBestHeader return (synced, ourHeight) -headerSync :: (MonadLogger m, MonadIO m, MonadBaseControl IO m)+headerSync :: (MonadLoggerIO m, MonadBaseControl IO m) => NodeT m () headerSync = do -- Start the header sync@@ -486,7 +478,7 @@ -- Continue the download if we are not yet synced else headerSync -peerHeaderSyncLimit :: (MonadLogger m, MonadIO m, MonadBaseControl IO m)+peerHeaderSyncLimit :: (MonadLoggerIO m, MonadBaseControl IO m) => PeerId -> PeerHost -> Int@@ -508,7 +500,7 @@ _ -> return False -- Sync all the headers from a given peer-peerHeaderSyncFull :: (MonadLogger m, MonadIO m, MonadBaseControl IO m)+peerHeaderSyncFull :: (MonadLoggerIO m, MonadBaseControl IO m) => PeerId -> PeerHost -> NodeT m ()@@ -529,12 +521,12 @@ headersSynced <- areHeadersSynced bestBlock <- readTVarS sharedBestBlock bestHeader <- readTVarS sharedBestHeader- return $ headersSynced && bestBlock == nodeBlockHash bestHeader+ return $ headersSynced && nodeHash bestBlock == nodeHash bestHeader -- Check if the block headers are synced with the network height areHeadersSynced :: NodeT STM Bool areHeadersSynced = do- ourHeight <- liftM nodeHeaderHeight $ readTVarS sharedBestHeader+ ourHeight <- nodeBlockHeight <$> readTVarS sharedBestHeader netHeight <- readTVarS sharedNetworkHeight -- If netHeight == 0 then we did not connect to any peers yet return $ ourHeight >= netHeight && netHeight > 0@@ -542,7 +534,7 @@ -- | Sync one batch of headers from the given peer. Accept the result of a -- previous peerHeaderSync to correctly compute block locators in the -- presence of side chains.-peerHeaderSync :: (MonadLogger m, MonadIO m, MonadBaseControl IO m)+peerHeaderSync :: (MonadLoggerIO m, MonadBaseControl IO m) => PeerId -> PeerHost -> Maybe BlockChainAction@@ -553,23 +545,31 @@ lock <- asks sharedSyncLock liftBaseOp_ (Lock.with lock) $ do + best <- atomicallyNodeT $ readTVarS sharedBestHeader+ -- Retrieve the block locator loc <- case prevM of Just (KnownChain ns) -> do- $(logDebug) $ formatPid pid ph "Building a KnownChain locator"- runHeaderTree $ blockLocatorHeight $ nodeHeaderHeight $ last ns- Just action@(SideChain _) -> do- $(logDebug) $ formatPid pid ph "Building a SideChain locator"- runHeaderTree $ blockLocatorSide action- _ -> do- $(logDebug) $ formatPid pid ph "Building a regular locator"- runHeaderTree blockLocator+ $(logDebug) $ formatPid pid ph "Building a known chain locator"+ runSqlNodeT $ blockLocator $ last ns+ Just (SideChain ns) -> do+ $(logDebug) $ formatPid pid ph "Building a side chain locator"+ runSqlNodeT $ blockLocator $ last ns+ Just (BestChain ns) -> do+ $(logDebug) $ formatPid pid ph "Building a best chain locator"+ runSqlNodeT $ blockLocator $ last ns+ Just (ChainReorg _ _ ns) -> do+ $(logDebug) $ formatPid pid ph "Building a reorg locator"+ runSqlNodeT $ blockLocator $ last ns+ Nothing -> do+ $(logDebug) $ formatPid pid ph "Building a locator to best"+ runSqlNodeT $ blockLocator best $(logDebug) $ formatPid pid ph $ unwords [ "Requesting headers with block locator of size" , show $ length loc , "Start block:", cs $ blockHashToHex $ head loc- , "End block:", cs $ blockHashToHex $ last loc+ , "End block:", cs $ blockHashToHex $ last loc ] -- Send a GetHeaders message to the peer@@ -578,33 +578,31 @@ $(logDebug) $ formatPid pid ph "Waiting 2 minutes for headers..." -- Wait 120 seconds for a response or time out- continueE <- raceTimeout 120- (disconnectPeer pid ph)- waitHeaders+ continueE <- raceTimeout 120 (disconnectPeer pid ph) (waitHeaders best) -- Return True if we can continue syncing from this peer return $ either (const Nothing) id continueE where z = "0000000000000000000000000000000000000000000000000000000000000000" -- Wait for the headers to be available- waitHeaders = do+ waitHeaders best = do (rPid, headers) <- atomicallyNodeT $ takeTMVarS sharedHeaders if rPid == pid- then processHeaders headers- else waitHeaders- processHeaders (Headers []) = do+ then processHeaders best headers+ else waitHeaders best+ processHeaders _ (Headers []) = do $(logDebug) $ formatPid pid ph "Received empty headers. Finished downloading headers." -- Do not continue the header download return Nothing- processHeaders (Headers hs) = do+ processHeaders best (Headers hs) = do $(logDebug) $ formatPid pid ph $ unwords [ "Received", show $ length hs, "headers." , "Start blocks:", cs $ blockHashToHex $ headerHash $ fst $ head hs , "End blocks:", cs $ blockHashToHex $ headerHash $ fst $ last hs ]- now <- liftM round $ liftIO getPOSIXTime- actionE <- runHeaderTree $ connectHeaders (map fst hs) now True+ now <- round <$> liftIO getPOSIXTime+ actionE <- runSqlNodeT $ connectHeaders best (map fst hs) now case actionE of Left err -> do misbehaving pid ph severeDoS err@@ -619,7 +617,7 @@ [ "Received", show $ length nodes , "nodes in the action" ]- let height = nodeHeaderHeight $ last nodes+ let height = nodeBlockHeight $ last nodes case action of KnownChain _ -> $(logInfo) $ formatPid pid ph $ unwords@@ -650,26 +648,34 @@ nodeStatusPeers <- mapM peerStatus =<< getPeers SharedNodeState{..} <- ask lift $ do- nodeStatusNetworkHeight <- readTVar sharedNetworkHeight- nodeStatusBestHeader <- liftM nodeBlockHash $- readTVar sharedBestHeader- nodeStatusBestHeaderHeight <- liftM nodeHeaderHeight $- readTVar sharedBestHeader- nodeStatusBestBlock <- readTVar sharedBestBlock- nodeStatusBloomSize <- liftM (maybe 0 (S.length . bloomData . fst)) $- readTVar sharedBloomFilter- nodeStatusHeaderPeer <- liftM (fmap hashUnique) $- readTVar sharedHeaderPeer- nodeStatusMerklePeer <- liftM (fmap hashUnique) $- readTVar sharedMerklePeer- nodeStatusHaveHeaders <- liftM not $ isEmptyTMVar sharedHeaders- nodeStatusHaveTickles <- liftM not $ isEmptyTBMChan sharedTickleChan- nodeStatusHaveTxs <- liftM not $ isEmptyTBMChan sharedTxChan- nodeStatusGetData <- liftM M.keys $ readTVar sharedTxGetData- nodeStatusRescan <- tryReadTMVar sharedRescan- nodeStatusMempool <- readTVar sharedMempool- nodeStatusSyncLock <- locked sharedSyncLock- nodeStatusLevelDBLock <- locked sharedLevelDBLock+ best <- readTVar sharedBestBlock+ header <- readTVar sharedBestHeader+ let nodeStatusBestBlock = nodeHash best+ nodeStatusBestBlockHeight = nodeBlockHeight best+ nodeStatusBestHeader = nodeHash header+ nodeStatusBestHeaderHeight = nodeBlockHeight header+ nodeStatusNetworkHeight <-+ readTVar sharedNetworkHeight+ nodeStatusBloomSize <-+ maybe 0 (S.length . bloomData . fst) <$> readTVar sharedBloomFilter+ nodeStatusHeaderPeer <-+ fmap hashUnique <$> readTVar sharedHeaderPeer+ nodeStatusMerklePeer <-+ fmap hashUnique <$> readTVar sharedMerklePeer+ nodeStatusHaveHeaders <-+ not <$> isEmptyTMVar sharedHeaders+ nodeStatusHaveTickles <-+ not <$> isEmptyTBMChan sharedTickleChan+ nodeStatusHaveTxs <-+ not <$> isEmptyTBMChan sharedTxChan+ nodeStatusGetData <-+ M.keys <$> readTVar sharedTxGetData+ nodeStatusRescan <-+ tryReadTMVar sharedRescan+ nodeStatusMempool <-+ readTVar sharedMempool+ nodeStatusSyncLock <-+ locked sharedSyncLock return NodeStatus{..} peerStatus :: (PeerId, PeerSession) -> NodeT STM PeerStatus@@ -683,13 +689,12 @@ peerStatusUserAgent = C.unpack . getVarString . userAgent <$> peerSessionVersion peerStatusPing = show <$> peerSessionScore- peerStatusThreadId = show peerSessionThreadId peerStatusDoSScore = peerHostSessionScore <$> hostM peerStatusLog = peerHostSessionLog <$> hostM peerStatusReconnectTimer = peerHostSessionReconnect <$> hostM lift $ do- peerStatusHaveMerkles <- liftM not $ isEmptyTBMChan peerSessionMerkleChan- peerStatusHaveMessage <- liftM not $ isEmptyTBMChan peerSessionChan+ peerStatusHaveMerkles <- not <$> isEmptyTBMChan peerSessionMerkleChan+ peerStatusHaveMessage <- not <$> isEmptyTBMChan peerSessionChan peerStatusPingNonces <- readTVar peerSessionPings return PeerStatus{..}
Network/Haskoin/Node/HeaderTree.hs view
@@ -1,451 +1,392 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-} module Network.Haskoin.Node.HeaderTree-( HeaderTree(..)-, BlockHeaderNode(..)-, BlockChainAction(..)+( BlockChainAction(..) , BlockHeight+, NodeBlock , Timestamp , initHeaderTree-, connectHeader-, connectHeaders-, commitAction+, migrateHeaderTree+, getBestBlock+, getHeads+, getBlockByHash+, getParentBlock+, getBlockWindow+, getBlockAfterTime+, getChildBlocks+, getBlockByHeight+, getBlocksByHeight+, getBlocksFromHeight+, getBlocksAtHeight+, putBlock+, putBlocks+, genesisBlock+, splitBlock+, splitChains+, nodeBlock+, nodeBlockHeight+, nodeHash+, nodeHeader+, nodePrev+, nodeTimestamp , isBestChain , isChainReorg , isSideChain , isKnownChain+, connectHeader+, connectHeaders , blockLocator-, blockLocatorHeight-, blockLocatorSide-, blockLocatorPartial-, getNodeWindow-, bestBlockHeaderHeight-, getBlockHeaderHeight-, getNodeAtTimestamp-, genesisNode-, getParentNode ) where -import Control.Monad (foldM, when, unless, liftM, (<=<), forM, forM_)-import Control.Monad.Trans (lift, liftIO, MonadIO)-import Control.Monad.Trans.Either (EitherT, left, runEitherT)-import Control.Monad.Reader (MonadReader(..), ReaderT, ask)-import Control.DeepSeq (NFData(..))+import Control.Monad (foldM, forM, unless,+ when, (<=<))+import Control.Monad.State (evalStateT, get, put)+import Control.Monad.Trans (MonadIO, lift)+import Control.Monad.Trans.Either (EitherT, left,+ runEitherT)+import Data.Bits (shiftL)+import qualified Data.ByteString as BS (reverse, take)+import Data.Function (on)+import Data.List (find, maximumBy, sort)+import Data.Maybe (fromMaybe, isNothing,+ listToMaybe, mapMaybe)+import Data.String.Conversions (cs)+import Data.Word (Word32)+import Database.Esqueleto (Esqueleto, Value, asc,+ delete, from, groupBy,+ in_, insertMany_, limit,+ max_, not_, orderBy,+ select, set, unValue,+ update, val, valList,+ where_, (!=.), (&&.),+ (<=.), (=.), (==.),+ (>.), (>=.), (^.),+ (||.))+import Database.Persist (Entity (..), insert_)+import Database.Persist.Sql (SqlPersistT)+import Network.Haskoin.Block+import Network.Haskoin.Constants+import Network.Haskoin.Crypto+import Network.Haskoin.Node.Checkpoints+import Network.Haskoin.Node.HeaderTree.Model+import Network.Haskoin.Node.HeaderTree.Types+import Network.Haskoin.Util -import Data.Word (Word32)-import Data.Bits (shiftL)-import Data.Maybe (fromMaybe, isNothing, isJust, catMaybes)-import Data.List (sort)-import Data.Binary.Get (getWord32le)-import Data.Binary.Put (putWord32le)-import Data.Default (def)-import qualified Data.Binary as B (Binary, get, put)-import qualified Data.ByteString as BS (ByteString, reverse, append)+data BlockChainAction+ = BestChain { actionNodes :: ![NodeBlock] }+ | ChainReorg { actionSplitNode :: !NodeBlock+ , actionOldNodes :: ![NodeBlock]+ , actionNodes :: ![NodeBlock]+ }+ | SideChain { actionNodes :: ![NodeBlock] }+ | KnownChain { actionNodes :: ![NodeBlock] }+ deriving (Show, Eq) -import qualified Database.LevelDB.Base as L (DB, get, put)+type MinWork = Word32 -import Network.Haskoin.Block-import Network.Haskoin.Constants-import Network.Haskoin.Util-import Network.Haskoin.Node.Checkpoints+shortHash :: BlockHash -> ShortHash+shortHash = decode' . BS.take 8 . getHash256 . getBlockHash -type BlockHeight = Word32-type Timestamp = Word32+nodeHeader :: NodeBlock -> BlockHeader+nodeHeader = getNodeHeader . nodeBlockHeader -class Monad m => HeaderTree m where- getBlockHeaderNode :: BlockHash -> m (Maybe BlockHeaderNode)- putBlockHeaderNode :: BlockHeaderNode -> m ()- -- The height is only updated when the node is part of the main chain.- -- Side chains are not indexed by their height.- putBlockHeaderHeight :: BlockHeaderNode -> m ()- getBlockHeaderByHeight :: BlockHeight -> m (Maybe BlockHeaderNode)- getBestBlockHeader :: m BlockHeaderNode- setBestBlockHeader :: BlockHeaderNode -> m ()+nodeHash :: NodeBlock -> BlockHash+nodeHash = headerHash . nodeHeader --- | Data type representing a BlockHeader node in the header chain. It--- contains additional data such as the chain work and chain height for this--- node.-data BlockHeaderNode = BlockHeaderNode- { nodeBlockHash :: !BlockHash- , nodeHeader :: !BlockHeader- , nodeHeaderHeight :: !BlockHeight- , nodeChainWork :: !Integer- , nodeChild :: !(Maybe BlockHash)- , nodeMedianTimes :: ![Timestamp]- , nodeMinWork :: !Word32 -- Only used for testnet- } deriving (Show, Read, Eq)+nodePrev :: NodeBlock -> BlockHash+nodePrev = prevBlock . nodeHeader -instance NFData BlockHeaderNode where- rnf BlockHeaderNode{..} =- rnf nodeBlockHash `seq`- rnf nodeHeader `seq`- rnf nodeHeaderHeight `seq`- rnf nodeChainWork `seq`- rnf nodeChild `seq`- rnf nodeMedianTimes `seq`- rnf nodeMinWork+nodeTimestamp :: NodeBlock -> Timestamp+nodeTimestamp = blockTimestamp . nodeHeader -instance B.Binary BlockHeaderNode where+-- | Number of blocks on average between difficulty cycles (2016 blocks).+diffInterval :: Word32+diffInterval = targetTimespan `div` targetSpacing - get = do- nodeBlockHash <- B.get- nodeHeader <- B.get- nodeHeaderHeight <- getWord32le- nodeChainWork <- B.get- nodeChild <- B.get- nodeMedianTimes <- B.get- nodeMinWork <- B.get- return BlockHeaderNode{..}+-- | Genesis block.+genesisBlock :: NodeBlock+genesisBlock = NodeBlock+ { nodeBlockHash = shortHash $ headerHash genesisHeader+ , nodeBlockHeader = NodeHeader genesisHeader+ , nodeBlockWork = 1.0+ , nodeBlockHeight = 0+ , nodeBlockChain = 0+ } - put BlockHeaderNode{..} = do- B.put nodeBlockHash- B.put nodeHeader- putWord32le nodeHeaderHeight- B.put nodeChainWork- B.put nodeChild- B.put nodeMedianTimes- B.put nodeMinWork+-- | Initialize the block header chain by inserting the genesis block if it+-- doesn't already exist.+initHeaderTree :: MonadIO m => SqlPersistT m ()+initHeaderTree = do+ nodeM <- getBlockByHash $ headerHash genesisHeader+ when (isNothing nodeM) $ putBlock genesisBlock -data BlockChainAction- = BestChain { actionNodes :: ![BlockHeaderNode] }- | ChainReorg { actionSplitNode :: !BlockHeaderNode- , actionOldNodes :: ![BlockHeaderNode]- , actionNodes :: ![BlockHeaderNode]- }- | SideChain { actionNodes :: ![BlockHeaderNode] }- | KnownChain { actionNodes :: ![BlockHeaderNode] }- deriving (Read, Show, Eq)+getVerifyParams+ :: MonadIO m+ => BlockHeader+ -> EitherT String (SqlPersistT m)+ (NodeBlock, [Timestamp], Timestamp, Word32, Maybe Word32)+getVerifyParams bh = do+ parentM <- lift $ getBlockByHash $ prevBlock bh+ parent <- maybe (left "Could not get parent node") return parentM+ checkPointM <- fmap nodeBlockHeight <$> lift lastSeenCheckpoint+ diffBlockM <- lift $ getBlockByHeight parent $+ nodeBlockHeight parent `div` diffInterval * diffInterval+ diffTime <- maybe (left "Could not get difficulty change block")+ (return . nodeTimestamp)+ diffBlockM+ medianBlocks <- lift $ map nodeTimestamp <$>+ getBlocksFromHeight parent 11 (min 0 $ nodeBlockHeight parent - 10)+ minWork <- lift $ findMinWork parent+ return (parent, medianBlocks, diffTime, minWork, checkPointM) -instance NFData BlockChainAction where- rnf bca = case bca of- BestChain ns -> rnf ns- ChainReorg s os ns -> rnf s `seq` rnf os `seq` rnf ns- KnownChain ns -> rnf ns- SideChain ns -> rnf ns+findMinWork :: MonadIO m => NodeBlock -> SqlPersistT m MinWork+findMinWork bn+ | isMinWork bn = return $ blockBits $ nodeHeader bn+ | otherwise = getParentBlock bn >>=+ maybe (return $ blockBits $ nodeHeader bn) findMinWork --- | Returns True if the action is a best chain+isMinWork :: NodeBlock -> Bool+isMinWork bn+ | not allowMinDifficultyBlocks = True+ | nodeBlockHeight bn `mod` diffInterval == 0 = True+ | blockBits (nodeHeader bn) /= encodeCompact powLimit = True+ | otherwise = False++splitKnown :: MonadIO m+ => [BlockHeader]+ -> SqlPersistT m ([NodeBlock], [BlockHeader])+splitKnown hs = do+ (kno, unk) <- foldM f ([], []) hs+ return (reverse kno, reverse unk)+ where+ f (kno, []) n = do+ bnM <- getBlockByHash (headerHash n)+ case bnM of+ Nothing -> return (kno, [n])+ Just bn -> return (bn:kno, [])+ f (kno, unk) n = return (kno, n:unk)++-- | Connect a block header to this block header chain. Corresponds to bitcoind+-- function ProcessBlockHeader and AcceptBlockHeader in main.cpp.+connectHeader :: MonadIO m+ => NodeBlock+ -> BlockHeader+ -> Timestamp+ -> SqlPersistT m (Either String BlockChainAction)+connectHeader best bh ts = runEitherT $ do+ (kno, _) <- lift $ splitKnown [bh]+ case kno of+ [] -> do+ (parent, medians, diffTime, minWork, cpM) <- getVerifyParams bh+ chain <- lift $ getChain parent+ let bn = nodeBlock parent chain bh+ liftEither $+ verifyBlockHeader parent medians diffTime cpM minWork ts bh+ lift $ putBlock bn+ lift $ evalNewChain best [bn]+ _ -> return $ KnownChain kno++-- | A more efficient way of connecting a list of block headers than connecting+-- them individually. The list of block headers have must form a valid chain.+connectHeaders :: MonadIO m+ => NodeBlock+ -> [BlockHeader]+ -> Timestamp+ -> SqlPersistT m (Either String BlockChainAction)+connectHeaders _ [] _ = runEitherT $ left "Nothing to connect"+connectHeaders best bhs ts = runEitherT $ do+ unless (validChain bhs) $ left "Block headers do not form a valid chain"+ (kno, unk) <- lift $ splitKnown bhs+ case unk of+ [] -> return $ KnownChain kno+ (bh:_) -> do+ (parent, medians, diffTime, minWork, cpM) <- getVerifyParams bh+ chain <- lift $ getChain parent+ nodes <- (`evalStateT` (parent, diffTime, medians, minWork)) $+ forM unk $ \b -> do+ (p, d, ms, mw) <- get+ lift $ liftEither $ verifyBlockHeader p ms d cpM mw ts b+ let bn = nodeBlock p chain b+ d' = if nodeBlockHeight bn `mod` diffInterval == 0+ then blockTimestamp b+ else d+ ms' = blockTimestamp b : if length ms == 11+ then tail ms+ else ms+ mw' = if isMinWork bn then blockBits b else mw+ put (bn, d', ms', mw')+ return bn+ lift $ putBlocks nodes+ lift $ evalNewChain best nodes+ where+ validChain (a:b:xs) = prevBlock b == headerHash a && validChain (b:xs)+ validChain [_] = True+ validChain _ = False++-- | Returns True if the action is a best chain. isBestChain :: BlockChainAction -> Bool isBestChain (BestChain _) = True isBestChain _ = False --- | Returns True if the action is a chain reorg+-- | Returns True if the action is a chain reorg. isChainReorg :: BlockChainAction -> Bool isChainReorg ChainReorg{} = True isChainReorg _ = False --- | Returns True if the action is a side chain+-- | Returns True if the action is a side chain. isSideChain :: BlockChainAction -> Bool isSideChain (SideChain _) = True isSideChain _ = False --- | Returns True if the action is a known chain+-- | Returns True if the action is a known chain. isKnownChain :: BlockChainAction -> Bool isKnownChain (KnownChain _) = True isKnownChain _ = False --- | Number of blocks on average between difficulty cycles (2016 blocks)-diffInterval :: Word32-diffInterval = targetTimespan `div` targetSpacing---- | Genesis BlockHeaderNode-genesisNode :: BlockHeaderNode-genesisNode = BlockHeaderNode- { nodeBlockHash = headerHash genesisHeader- , nodeHeader = genesisHeader- , nodeHeaderHeight = 0- , nodeChainWork = headerWork genesisHeader- , nodeChild = Nothing- , nodeMedianTimes = [blockTimestamp genesisHeader]- , nodeMinWork = blockBits genesisHeader- }---- | Initialize the block header chain by inserting the genesis block if--- it doesn't already exist.-initHeaderTree :: HeaderTree m => m ()-initHeaderTree = do- genM <- getBlockHeaderNode $ nodeBlockHash genesisNode- when (isNothing genM) $ do- putBlockHeaderNode genesisNode- putBlockHeaderHeight genesisNode- setBestBlockHeader genesisNode---- A more efficient way of connecting a list of BlockHeaders than connecting--- them individually. The work check will only be done once for the whole--- chain. The list of BlockHeaders have to form a valid chain, linked by their--- parents.-connectHeaders :: HeaderTree m- => [BlockHeader]- -> Timestamp- -> Bool- -> m (Either String BlockChainAction)-connectHeaders bhs adjustedTime commit- | null bhs = return $ Left "Invalid empty BlockHeaders in connectHeaders"- | validChain bhs = runEitherT $ do- newNodes <- forM bhs $ \bh -> do- parNode <- verifyBlockHeader bh adjustedTime- lift $ storeBlockHeader bh parNode- -- Best header will only be updated if we have no errors- lift $ evalNewChain commit newNodes- | otherwise = return $ Left "BlockHeaders do not form a valid chain."- where- validChain (a:b:xs) = prevBlock b == headerHash a && validChain (b:xs)- validChain [_] = True- validChain _ = False---- | Connect a block header to this block header chain. Corresponds to bitcoind--- function ProcessBlockHeader and AcceptBlockHeader in main.cpp.-connectHeader :: HeaderTree m- => BlockHeader- -> Timestamp- -> Bool- -> m (Either String BlockChainAction)-connectHeader bh adjustedTime commit = runEitherT $ do- parNode <- verifyBlockHeader bh adjustedTime- lift $ evalNewChain commit . (: []) =<< storeBlockHeader bh parNode--evalNewChain :: HeaderTree m- => Bool- -> [BlockHeaderNode]- -> m BlockChainAction-evalNewChain commit newNodes = do- currentHead <- getBestBlockHeader- action <- go =<< findSplitNode currentHead (last newNodes)- when commit $ commitAction action- return action- where- go (split, old, new)- | null old && not (null new) = return $ BestChain new- | not (null old) && not (null new) =- return $ if nodeChainWork (last new) > nodeChainWork (last old)- then ChainReorg split old new- else SideChain $ split : new- | otherwise = return $ KnownChain newNodes---- | Update the best block header of the action in the header tree-commitAction :: HeaderTree m => BlockChainAction -> m ()-commitAction action = do- currentHead <- getBestBlockHeader- case action of- BestChain nodes -> unless (null nodes) $ do- updateChildren $ currentHead:nodes- forM_ nodes putBlockHeaderHeight- setBestBlockHeader $ last nodes- ChainReorg s _ ns -> unless (null ns) $ do- updateChildren $ s:ns- forM_ ns putBlockHeaderHeight- setBestBlockHeader $ last ns- KnownChain _ -> return ()- SideChain _ -> return ()+-- | Returns a BlockLocator object for a given block hash.+blockLocator :: MonadIO m => NodeBlock -> SqlPersistT m BlockLocator+blockLocator node = do+ nodes <- getBlocksByHeight node bs+ return $ map nodeHash nodes where- updateChildren (a:b:xs) = do- putBlockHeaderNode a{ nodeChild = Just $ nodeBlockHash b }- updateChildren (b:xs)- updateChildren _ = return ()+ h = nodeBlockHeight node+ f x s = (fst x - s, fst x > s)+ bs = (++ [0]) $ map fst $ takeWhile snd $+ [(h - x, x < h) | x <- [0..9]] +++ scanl f (h - 10, h > 10) [2 ^ (x :: Word32) | x <- [1..]] +-- | Verify block header conforms to protocol.+verifyBlockHeader :: NodeBlock -- ^ Parent block header+ -> [Timestamp] -- ^ Timestamps of previous 11 blocks+ -> Timestamp -- ^ Previous difficulty change+ -> Maybe Word32 -- ^ Height of most recent checkpoint+ -> MinWork -- ^ Last MinWork (e.g. Testnet3)+ -> Timestamp -- ^ Current time+ -> BlockHeader -- ^ Block header to validate+ -> Either String () -- TODO: Add DOS return values-verifyBlockHeader :: HeaderTree m- => BlockHeader- -> Timestamp- -> EitherT String m BlockHeaderNode-verifyBlockHeader bh adjustedTime = do- unless (isValidPOW bh) $ left "Invalid proof of work"-- unless (blockTimestamp bh <= adjustedTime + 2 * 60 * 60) $- left "Invalid header timestamp"+verifyBlockHeader par mts dt cp mw ts bh = do+ unless (isValidPOW bh) $+ Left "Invalid proof of work" - parNodeM <- lift $ getBlockHeaderNode $ prevBlock bh- parNode <- maybe (left "Parent block not found") return parNodeM+ unless (blockTimestamp bh <= ts + 2 * 60 * 60) $+ Left "Invalid header timestamp" - nextWork <- lift $ nextWorkRequired parNode bh- unless (blockBits bh == nextWork) $ left "Incorrect work transition (bits)"+ let nextWork = nextWorkRequired par dt mw bh+ unless (blockBits bh == nextWork) $+ Left "Incorrect work transition (bits)" - let sortedMedians = sort $ nodeMedianTimes parNode+ let sortedMedians = sort mts medianTime = sortedMedians !! (length sortedMedians `div` 2)- when (blockTimestamp bh <= medianTime) $ left "Block timestamp is too early"+ when (blockTimestamp bh <= medianTime) $+ Left "Block timestamp is too early" - chkPointM <- lift lastSeenCheckpoint- let newHeight = nodeHeaderHeight parNode + 1- unless (maybe True ((fromIntegral newHeight >) . fst) chkPointM) $- left "Rewriting pre-checkpoint chain"+ let newHeight = nodeBlockHeight par + 1+ unless (maybe True (fromIntegral newHeight >) cp) $+ Left "Rewriting pre-checkpoint chain" - unless (verifyCheckpoint (fromIntegral newHeight) bid) $- left "Rejected by checkpoint lock-in"+ unless (verifyCheckpoint (fromIntegral newHeight) (headerHash bh)) $+ Left "Rejected by checkpoint lock-in" -- All block of height 227836 or more use version 2 in prodnet -- TODO: Find out the value here for testnet- when ( networkName == "prodnet"- && blockVersion bh == 1- && nodeHeaderHeight parNode + 1 >= 227836) $- left "Rejected version=1 block"+ when (networkName == "prodnet"+ && blockVersion bh == 1+ && nodeBlockHeight par + 1 >= 227836) $+ Left "Rejected version 1 block" - return parNode+-- | Create a block node data structure from a block header.+nodeBlock :: NodeBlock -- ^ Parent block node+ -> Word32 -- ^ Chain number for new node+ -> BlockHeader+ -> NodeBlock+nodeBlock parent chain bh = NodeBlock+ { nodeBlockHash = shortHash $ headerHash bh+ , nodeBlockHeader = NodeHeader bh+ , nodeBlockWork = newWork+ , nodeBlockHeight = height+ , nodeBlockChain = chain+ } where- bid = headerHash bh+ newWork = nodeBlockWork parent + fromIntegral+ (headerWork bh `div` headerWork genesisHeader)+ height = nodeBlockHeight parent + 1 --- Build a new block header and store it-storeBlockHeader :: HeaderTree m- => BlockHeader- -> BlockHeaderNode- -> m BlockHeaderNode-storeBlockHeader bh parNode = do- let nodeBlockHash = bid- nodeHeader = bh- nodeHeaderHeight = newHeight- nodeChainWork = newWork- nodeChild = Nothing- nodeMedianTimes = newMedian- nodeMinWork = minWork- newNode = BlockHeaderNode{..}- prevM <- getBlockHeaderNode bid- case prevM of- Just prev -> return prev- Nothing -> putBlockHeaderNode newNode >> return newNode- where- bid = headerHash bh- newHeight = nodeHeaderHeight parNode + 1- newWork = nodeChainWork parNode + headerWork bh- newMedian = blockTimestamp bh : take 10 (nodeMedianTimes parNode)- isDiffChange = newHeight `mod` diffInterval == 0- isNotLimit = blockBits bh /= encodeCompact powLimit- minWork | not allowMinDifficultyBlocks = 0- | isDiffChange || isNotLimit = blockBits bh- | otherwise = nodeMinWork parNode+-- | Return blockchain action to connect given block with best block. Count will+-- limit the amount of blocks building up from split point towards the best+-- block.+getBlockWindow :: MonadIO m+ => NodeBlock -- ^ Best block+ -> NodeBlock -- ^ Start of window+ -> Word32 -- ^ Window count+ -> SqlPersistT m BlockChainAction+getBlockWindow best node cnt = do+ (_, old, new) <- splitChains (node, 0) (best, cnt)+ return $ if null old then BestChain new else ChainReorg node old new --- | Return the window of nodes starting from the child of the given node.--- Child links are followed to build the window. If the window ends in an--- orphaned chain, we backtrack and return the window in the main chain.--- The result is returned in a BlockChainAction to know if we had to--- backtrack into the main chain or not.-getNodeWindow :: HeaderTree m- => BlockHash -> Int -> m (Maybe BlockChainAction)-getNodeWindow bh cnt = getBlockHeaderNode bh >>= \nodeM -> case nodeM of- Just node -> go [] cnt node- Nothing -> return Nothing- where- go [] 0 _ = return Nothing- go acc 0 _ = return $ Just $ BestChain $ reverse acc- go acc i node = getChildNode node >>= \childM -> case childM of- Just child -> go (child:acc) (i-1) child- Nothing -> do- -- We are at the end of our chain. Check if there is a better chain.- currentHead <- getBestBlockHeader- if nodeChainWork currentHead > nodeChainWork node- -- We got stuck in an orphan chain. We need to backtrack.- then findMainChain currentHead- -- We are at the end of the main chain- else return $ if null acc- then Nothing- else Just $ BestChain $ reverse acc- findMainChain currentHead = do- -- Compute the split point from the original input node so that the old- -- chain doesn't contain blocks beyond the original node.- node <- fromMaybe e <$> getBlockHeaderNode bh- (split, old, new) <- findSplitNode node currentHead- return $ Just $ ChainReorg split old $ take cnt new- e = error "getNodeWindow: Could not get block header node"+-- | Find the split point between two nodes. It also returns the two partial+-- chains leading from the split point to the respective nodes. Tuples must+-- contain a block node and the count of nodes that should be returned from the+-- split towards that block. 0 means all.+splitChains :: MonadIO m+ => (NodeBlock, Word32)+ -> (NodeBlock, Word32)+ -> SqlPersistT m (NodeBlock, [NodeBlock], [NodeBlock])+splitChains (l, ln) (r, rn) = do+ sn <- splitBlock l r+ (split:ls) <- getBlocksFromHeight l ln (nodeBlockHeight sn)+ rs <- getBlocksFromHeight r rn (nodeBlockHeight sn + 1)+ return (split, ls, rs) --- Find the first node right after the given timestamp-getNodeAtTimestamp :: HeaderTree m- => Timestamp- -> m (Maybe BlockHeaderNode)-getNodeAtTimestamp ts = do- best <- getBestBlockHeader- if ts < blockTimestamp (nodeHeader best)- -- there is a solution. Perform a binary search.- then go 0 $ nodeHeaderHeight best- -- There is no solution.- else return Nothing+-- | Finds the parent of a block.+getParentBlock :: MonadIO m+ => NodeBlock+ -> SqlPersistT m (Maybe NodeBlock)+getParentBlock node+ | nodeBlockHeight node == 0 = return Nothing+ | otherwise = getBlockByHash p where- go a b- | a == b = getBlockHeaderByHeight a- | otherwise = do- -- compute the middle point- let m = a + ((b - a) `div` 2)- nodeM <- getBlockHeaderByHeight m- case nodeM of- Just node -> if ts < blockTimestamp (nodeHeader node)- -- The block is after the timestamp. The block could be the- -- solution, or the solution is smaller.- then go a m- -- The block is before the timestamp. The solution is- -- striclty higher than m.- else go (m+1) b- _ -> error $ unwords- [ "getNodeAtTimestamp: Possibly corrupted chain"- , "at height", show m- ]+ p = nodePrev node --- | Find the split point between two nodes. It also returns the two partial--- chains leading from the split point to the respective nodes.-findSplitNode :: HeaderTree m- => BlockHeaderNode- -> BlockHeaderNode- -> m (BlockHeaderNode, [BlockHeaderNode], [BlockHeaderNode])-findSplitNode =- go [] []+-- | Get all children for a block+getChildBlocks :: MonadIO m+ => BlockHash+ -> SqlPersistT m [NodeBlock]+getChildBlocks h = do+ ch <- (+1) . nodeBlockHeight . fromMaybe e <$> getBlockByHash h+ filter ((==h) . nodePrev) <$> getBlocksAtHeight ch where- go xs ys x y- | nodeBlockHash x == nodeBlockHash y = return (x, xs, ys)- | nodeHeaderHeight x > nodeHeaderHeight y = do- par <- fromMaybe e <$> getParentNode x- go (x:xs) ys par y- | otherwise = do- par <- fromMaybe e <$> getParentNode y- go xs (y:ys) x par- e = error "findSplitNode: Could not get parent node"+ e = error $ "Cannot find block hash " ++ cs (blockHashToHex h) --- | Finds the parent of a BlockHeaderNode-getParentNode :: HeaderTree m => BlockHeaderNode -> m (Maybe BlockHeaderNode)-getParentNode node- | p == z = return Nothing- | otherwise = getBlockHeaderNode p- where- p = prevBlock $ nodeHeader node- z = "0000000000000000000000000000000000000000000000000000000000000000" --- | Finds the child of a BlockHeaderNode if it exists. If a node has--- multiple children, this function will always return the child on the--- main branch.-getChildNode :: HeaderTree m => BlockHeaderNode -> m (Maybe BlockHeaderNode)-getChildNode node = case nodeChild node of- Just child -> getBlockHeaderNode child- Nothing -> return Nothing---- | Get the last checkpoint that we have seen-lastSeenCheckpoint :: HeaderTree m => m (Maybe (Int, BlockHash))+-- | Get the last checkpoint that we have seen.+lastSeenCheckpoint :: MonadIO m+ => SqlPersistT m (Maybe NodeBlock) lastSeenCheckpoint =- go $ reverse checkpointList- where- go ((i, chk):xs) = do- existsChk <- liftM isJust $ getBlockHeaderNode chk- if existsChk then return $ Just (i, chk) else go xs- go [] = return Nothing+ fmap listToMaybe $ getBlocksByHash $ map snd $ reverse checkpointList --- | Returns the work required for a BlockHeader given the previous--- BlockHeaderNode. This function coresponds to bitcoind function--- GetNextWorkRequired in main.cpp.-nextWorkRequired :: HeaderTree m => BlockHeaderNode -> BlockHeader -> m Word32-nextWorkRequired lastNode bh+-- | Returns the work required for a block header given the previous block. This+-- coresponds to bitcoind function GetNextWorkRequired in main.cpp.+nextWorkRequired :: NodeBlock+ -> Timestamp+ -> MinWork+ -> BlockHeader+ -> Word32+nextWorkRequired par ts mw bh -- Genesis block- | prevBlock (nodeHeader lastNode) == z = return $ encodeCompact powLimit+ | nodeBlockHeight par == 0 = encodeCompact powLimit -- Only change the difficulty once per interval- | (nodeHeaderHeight lastNode + 1) `mod` diffInterval /= 0 = return $+ | (nodeBlockHeight par + 1) `mod` diffInterval /= 0 = if allowMinDifficultyBlocks then minPOW- else blockBits $ nodeHeader lastNode- | otherwise = do- -- TODO: Can this break if there are not enough blocks in the chain?- firstNode <- foldM (flip ($)) lastNode fs- let lastTs = blockTimestamp $ nodeHeader firstNode- return $ workFromInterval lastTs (nodeHeader lastNode)+ else blockBits $ nodeHeader par+ | otherwise = workFromInterval ts (nodeHeader par) where- len = fromIntegral diffInterval - 1- fs = replicate len (liftM (fromMaybe e) . getParentNode)- e = error "nextWorkRequired: Could not get parent node" delta = targetSpacing * 2 minPOW- | blockTimestamp bh > blockTimestamp (nodeHeader lastNode) + delta =- encodeCompact powLimit- | otherwise = nodeMinWork lastNode- z = "0000000000000000000000000000000000000000000000000000000000000000"+ | blockTimestamp bh > nodeTimestamp par + delta = encodeCompact powLimit+ | otherwise = mw -- | Computes the work required for the next block given a timestamp and the -- current block. The timestamp should come from the block that matched the@@ -463,55 +404,10 @@ lastDiff = decodeCompact $ blockBits lastB newDiff = lastDiff * toInteger actualTime `div` toInteger targetTimespan --- | Returns a BlockLocator object (newest block first, genesis at the end)-blockLocator :: HeaderTree m => m BlockLocator-blockLocator = bestBlockHeaderHeight >>= blockLocatorHeight---- | Returns a BlockLocator object for a given block height on the main chain.-blockLocatorHeight :: HeaderTree m => BlockHeight -> m BlockLocator-blockLocatorHeight height = do- -- Take only indices > 0 to avoid the genesis block- let is = takeWhile (> (0 :: Int)) $- [h, (h - 1) .. (h - 9)] ++ [(h - 10) - 2^x | x <- [(0 :: Int)..]]- ns <- liftM catMaybes $ forM (map fromIntegral is) getBlockHeaderByHeight- return $ map nodeBlockHash ns ++ [headerHash genesisHeader]- where- h = fromIntegral height---- | Build a block locator starting from a side chain. We do not have access--- to the height index for the portion of the side chain so we build the--- part in the side chain manually, then use the block height index for the--- rest of the locator once we're back on the main chain.-blockLocatorSide :: HeaderTree m => BlockChainAction -> m BlockLocator-blockLocatorSide action = case action of- SideChain (split:nodes) -> do- mainLoc <- blockLocatorHeight $ nodeHeaderHeight split- return $ take 10 (map nodeBlockHash $ reverse nodes) ++ mainLoc- _ -> error "blockLocatorSide: Invalid blockchain action provided"---- | Returns a partial BlockLocator object.-blockLocatorPartial :: HeaderTree m => Int -> m BlockLocator-blockLocatorPartial i- | i < 1 = error "Locator length must be greater than 0"- | otherwise = do- h <- getBestBlockHeader- liftM (map nodeBlockHash . reverse) $ go [] i h- where- go acc 1 node = return $ node:acc- go acc step node = getParentNode node >>= \parM -> case parM of- Just par -> go (node:acc) (step - 1) par- Nothing -> return $ node:acc--bestBlockHeaderHeight :: HeaderTree m => m BlockHeight-bestBlockHeaderHeight = liftM nodeHeaderHeight getBestBlockHeader--getBlockHeaderHeight :: HeaderTree m => BlockHash -> m (Maybe BlockHeight)-getBlockHeaderHeight = return . fmap nodeHeaderHeight <=< getBlockHeaderNode---- | Returns True if the difficulty target (bits) of the header is valid--- and the proof of work of the header matches the advertised difficulty target.--- This function corresponds to the function CheckProofOfWork from bitcoind--- in main.cpp+-- | Returns True if the difficulty target (bits) of the header is valid and the+-- proof of work of the header matches the advertised difficulty target. This+-- function corresponds to the function CheckProofOfWork from bitcoind in+-- main.cpp. isValidPOW :: BlockHeader -> Bool isValidPOW bh | target <= 0 || target > powLimit = False@@ -528,58 +424,221 @@ -- target. headerWork :: BlockHeader -> Integer headerWork bh =- largestHash `div` (target + 1)+ fromIntegral $ largestHash `div` (target + 1) where target = decodeCompact (blockBits bh) largestHash = 1 `shiftL` 256 -{- Default LevelDB implementation -}+{- Persistent backend -} -blockHashKey :: BlockHash -> BS.ByteString-blockHashKey bid = "b_" `BS.append` encode' bid+chainPathQuery :: forall (expr :: * -> *) (query :: * -> *) backend.+ Esqueleto query expr backend+ => expr (Entity NodeBlock)+ -> [NodeBlock]+ -> expr (Value Bool)+chainPathQuery _ [] = error "Monsters, monsters everywhere" -bestBlockKey :: BS.ByteString-bestBlockKey = "bestblockheader_"+chainPathQuery t [NodeBlock{..}] =+ t ^. NodeBlockHeight <=. val nodeBlockHeight &&.+ t ^. NodeBlockChain ==. val nodeBlockChain -heightKey :: BlockHeight -> BS.ByteString-heightKey h = "h_" `BS.append` encode' h+chainPathQuery t (n1:bs@(n2:_)) = chainPathQuery t bs ||.+ ( t ^. NodeBlockHeight <=. val (nodeBlockHeight n1)+ &&. t ^. NodeBlockHeight >. val (nodeBlockHeight n2)+ &&. t ^. NodeBlockChain ==. val (nodeBlockChain n1)+ ) --- Get a node which is directly referenced by the key-getLevelDBNode :: MonadIO m- => BS.ByteString -> ReaderT L.DB m (Maybe BlockHeaderNode)-getLevelDBNode key = do- db <- ask- resM <- liftIO $ L.get db def key- return $ decodeToMaybe =<< resM+getHeads :: MonadIO m => SqlPersistT m [NodeBlock]+getHeads = fmap (map (entityVal . snd)) $ select $ from $ \t -> do+ groupBy $ t ^. NodeBlockChain+ return (max_ (t ^. NodeBlockHeight), t) --- Get a node that has 1 level of indirection-getLevelDBNode' :: MonadIO m- => BS.ByteString -> ReaderT L.DB m (Maybe BlockHeaderNode)-getLevelDBNode' key = do- db <- ask- resM <- liftIO $ L.get db def key- maybe (return Nothing) getLevelDBNode resM+-- | Chain for new block building on a parent node+getChain :: MonadIO m+ => NodeBlock -- ^ Parent node+ -> SqlPersistT m Word32+getChain parent = do+ maxHeightM <- fmap (unValue <=< listToMaybe) $ select $ from $ \t -> do+ where_ $ t ^. NodeBlockChain ==. val (nodeBlockChain parent)+ return $ max_ $ t ^. NodeBlockHeight+ let maxHeight = fromMaybe (error "That chain does not exist") maxHeightM+ if maxHeight == nodeBlockHeight parent+ then return $ nodeBlockChain parent+ else do+ maxChainM <- fmap (unValue <=< listToMaybe) $ select $ from $ \t ->+ return $ max_ $ t ^. NodeBlockChain+ let maxChain = fromMaybe (error "Ran out of chains") maxChainM+ return $ maxChain + 1 -instance MonadIO m => HeaderTree (ReaderT L.DB m) where- getBlockHeaderNode = getLevelDBNode . blockHashKey- putBlockHeaderNode node = do- db <- ask- liftIO $ L.put db def (blockHashKey $ nodeBlockHash node) $ encode' node- getBlockHeaderByHeight = getLevelDBNode' . heightKey- putBlockHeaderHeight node = do- db <- ask- let val = blockHashKey $ nodeBlockHash node- liftIO $ L.put db def (heightKey $ nodeHeaderHeight node) val- getBestBlockHeader = do- db <- ask- keyM <- liftIO $ L.get db def bestBlockKey- case keyM of- Just key -> fromMaybe e <$> getLevelDBNode key- Nothing -> error- "GetBestBlockHeader: Best block header does not exist"- where- e = error "getBestBlockHeader: Could not get LevelDB node"- setBestBlockHeader node = do- db <- ask- liftIO $ L.put db def bestBlockKey $ blockHashKey $ nodeBlockHash node+getPivots :: MonadIO m => NodeBlock -> SqlPersistT m [NodeBlock]+getPivots = go []+ where+ go acc b+ | nodeBlockChain b == 0 = return $ genesisBlock : b : acc+ | otherwise = do+ l <- fromMaybe (error "Houston, we have a problem") <$>+ getChainLowest b+ c <- fromMaybe (error "Ground Control to Major Tom") <$>+ getParentBlock l+ go (b:acc) c +getChainLowest :: MonadIO m => NodeBlock -> SqlPersistT m (Maybe NodeBlock)+getChainLowest nb = fmap (listToMaybe . map entityVal) $+ select $ from $ \t -> do+ where_ $ t ^. NodeBlockChain ==. val (nodeBlockChain nb)+ orderBy [ asc $ t ^. NodeBlockHeight ]+ limit 1+ return t++-- | Get node height and chain common to both given.+splitBlock :: MonadIO m+ => NodeBlock+ -> NodeBlock+ -> SqlPersistT m NodeBlock+splitBlock l r = if nodeBlockChain l == nodeBlockChain r+ then if nodeBlockHeight l < nodeBlockHeight r+ then return l+ else return r+ else do+ pivotsL <- getPivots l+ pivotsR <- getPivots r+ let ns = zip pivotsL pivotsR+ f (x,y) = nodeBlockChain x == nodeBlockChain y+ (one, two) = last $ takeWhile f ns+ if nodeBlockHeight one < nodeBlockHeight two+ then return one+ else return two++-- | Put single block in database.+putBlock :: MonadIO m => NodeBlock -> SqlPersistT m ()+putBlock = insert_++-- | Put multiple blocks in database.+putBlocks :: MonadIO m => [NodeBlock] -> SqlPersistT m ()+putBlocks = mapM_ insertMany_ . f+ where+ f [] = []+ f xs = let (xs',xxs) = splitAt 50 xs in xs' : f xxs++getBestBlock :: MonadIO m => SqlPersistT m NodeBlock+getBestBlock =+ maximumBy (compare `on` nodeBlockWork) <$> getHeads++getBlockByHash :: MonadIO m => BlockHash -> SqlPersistT m (Maybe NodeBlock)+getBlockByHash h =+ fmap (listToMaybe . map entityVal) $ select $ from $ \t -> do+ where_ $ t ^. NodeBlockHash ==. val (shortHash h)+ return t++-- | Get multiple blocks corresponding to given hashes+getBlocksByHash :: MonadIO m+ => [BlockHash]+ -> SqlPersistT m [NodeBlock]+getBlocksByHash hashes = do+ nodes <- fmap (map entityVal) $ select $ from $ \t -> do+ where_ $ t ^. NodeBlockHash `in_` valList (map shortHash hashes)+ return t+ return $ mapMaybe+ (\h -> find ((== shortHash h) . nodeBlockHash) nodes)+ hashes++-- | Get ancestor of specified block at given height.+getBlockByHeight :: MonadIO m+ => NodeBlock -- ^ Best block+ -> BlockHeight+ -> SqlPersistT m (Maybe NodeBlock)+getBlockByHeight block height = do+ forks <- reverse <$> getPivots block+ fmap (listToMaybe . map entityVal) $ select $ from $ \t -> do+ where_ $ chainPathQuery t forks &&.+ t ^. NodeBlockHeight ==. val height+ return t++-- | Get ancestors for specified block at given heights.+getBlocksByHeight :: MonadIO m+ => NodeBlock -- ^ Best block+ -> [BlockHeight]+ -> SqlPersistT m [NodeBlock]+getBlocksByHeight best heights = do+ forks <- reverse <$> getPivots best+ nodes <- fmap (map entityVal) $ select $ from $ \t -> do+ where_ $ chainPathQuery t forks &&.+ t ^. NodeBlockHeight `in_` valList heights+ return t+ return $ mapMaybe (\h -> find ((==h) . nodeBlockHeight) nodes) heights++-- | Get a range of block headers building up to specified block. If+-- specified height is too large, an empty list will be returned.+getBlocksFromHeight :: MonadIO m+ => NodeBlock -- ^ Best block+ -> Word32 -- ^ Count (0 for all)+ -> BlockHeight -- ^ Height from (including)+ -> SqlPersistT m [NodeBlock]+getBlocksFromHeight block cnt height = do+ forks <- reverse <$> getPivots block+ fmap (map entityVal) $ select $ from $ \t -> do+ where_ $ chainPathQuery t forks &&.+ t ^. NodeBlockHeight >=. val height+ when (cnt > 0) $ limit $ fromIntegral cnt+ return t++-- | Get node immediately at or after timestamp in main chain.+getBlockAfterTime :: MonadIO m => Timestamp -> SqlPersistT m (Maybe NodeBlock)+getBlockAfterTime ts = do+ n@NodeBlock{..} <- getBestBlock+ f genesisBlock n+ where+ f l r | nodeTimestamp r < ts =+ return Nothing+ | nodeTimestamp l >= ts =+ return $ Just l+ | (nodeBlockHeight r - nodeBlockHeight l) `div` 2 == 0 =+ return $ Just r+ | otherwise = do+ let rh = nodeBlockHeight r+ lh = nodeBlockHeight l+ mh = rh - (rh - lh) `div` 2+ m <- fromMaybe (error "My God, it’s full of stars!") <$>+ getBlockByHeight r mh+ if nodeTimestamp m > ts then f l m else f m r++-- | Get blocks at specified height in all chains.+getBlocksAtHeight :: MonadIO m => BlockHeight -> SqlPersistT m [NodeBlock]+getBlocksAtHeight height = fmap (map entityVal) $ select $ from $ \t -> do+ where_ $ t ^. NodeBlockHeight ==. val height+ return t++-- | Evaluate block action for provided best block and chain of new blocks.+evalNewChain :: MonadIO m+ => NodeBlock+ -> [NodeBlock]+ -> SqlPersistT m BlockChainAction+evalNewChain _ [] = error "You find yourself in the dungeon of missing blocks"+evalNewChain best newNodes+ | buildsOnBest = do+ pruneChain best+ return $ BestChain $ map (\n -> n{ nodeBlockChain = 0 }) newNodes+ | nodeBlockWork (last newNodes) > nodeBlockWork best = do+ (split, old, new) <- splitChains (best, 0) (head newNodes, 0)+ return $ ChainReorg split old (new ++ tail newNodes)+ | otherwise = do+ (split, _, new) <- splitChains (best, 0) (head newNodes, 0)+ case new of+ [] -> return $ KnownChain newNodes+ _ -> return $ SideChain $ split : new ++ tail newNodes+ where+ buildsOnBest = nodePrev (head newNodes) == nodeHash best++pruneChain :: MonadIO m+ => NodeBlock+ -> SqlPersistT m ()+pruneChain best = do+ when (nodeBlockChain best /= 0) $ do+ forks <- reverse <$> getPivots best+ delete $ from $ \t -> do+ where_ $ not_ (chainPathQuery t forks)+ &&. t ^. NodeBlockHeight <=. val (nodeBlockHeight best)+ update $ \t -> do+ set t [ NodeBlockChain =. val 0 ]+ where_ $ t ^. NodeBlockHeight <=. val (nodeBlockHeight best)+ &&. t ^. NodeBlockChain !=. val 0
+ Network/Haskoin/Node/HeaderTree/Model.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+module Network.Haskoin.Node.HeaderTree.Model where++import Data.Word (Word32)+import Database.Persist.TH (mkMigrate, mkPersist,+ persistLowerCase, share,+ sqlSettings)+import Network.Haskoin.Node.HeaderTree.Types++share [mkPersist sqlSettings, mkMigrate "migrateHeaderTree"] [persistLowerCase|+NodeBlock+ hash ShortHash+ header NodeHeader maxlen=80+ work Work+ height BlockHeight+ chain Word32+ UniqueHash hash+ UniqueChain chain height+ deriving Show+ deriving Eq+|]
+ Network/Haskoin/Node/HeaderTree/Types.hs view
@@ -0,0 +1,27 @@+module Network.Haskoin.Node.HeaderTree.Types where++import Data.Word (Word32, Word64)+import Database.Persist (PersistField (..), PersistValue (..),+ SqlType (..))+import Database.Persist.Sql (PersistFieldSql (..))+import Network.Haskoin.Block+import Network.Haskoin.Util++type BlockHeight = Word32+type ShortHash = Word64+type Timestamp = Word32+type Work = Double++newtype NodeHeader = NodeHeader { getNodeHeader :: BlockHeader }+ deriving (Show, Eq)++{- SQL database backend for HeaderTree -}++instance PersistField NodeHeader where+ toPersistValue = PersistByteString . encode' . getNodeHeader+ fromPersistValue (PersistByteString bs) = maybeToEither+ "Could not decode block header" $ NodeHeader <$> decodeToMaybe bs+ fromPersistValue _ = Left "Invalid persistent block header"++instance PersistFieldSql NodeHeader where+ sqlType _ = SqlBlob
Network/Haskoin/Node/Peer.hs view
@@ -1,54 +1,58 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-} module Network.Haskoin.Node.Peer where -import System.Random (randomIO)--import Control.Monad (liftM, when, unless, join, forM_, forever)-import Control.Monad.Trans (MonadIO, lift, liftIO)-import Control.Monad.Trans.Control (MonadBaseControl)-import Control.Monad.Logger (MonadLogger, logInfo, logWarn, logDebug, logError)-import Control.Monad.Reader (ReaderT, asks, runReaderT)-import Control.Monad.State (StateT, evalStateT, get, put)-import Control.Concurrent (threadDelay, killThread, myThreadId)-import qualified Control.Concurrent.STM.Lock as Lock (with)-import Control.Exception.Lifted (fromException, finally, throwIO, throw)-import Control.Concurrent.STM.TBMChan- ( TBMChan, writeTBMChan, closeTBMChan, newTBMChan )-import Control.Concurrent.Async.Lifted- ( race, withAsync, waitAnyCancel, link, waitCatch )-import Control.Concurrent.STM- ( STM, atomically, readTVar, modifyTVar', swapTVar, retry, newTVarIO )--import Data.List (nub, sort, sortBy)-import Data.Text (Text, pack)-import Data.Word (Word32)-import Data.Maybe (fromMaybe, isJust, listToMaybe)-import Data.Time.Clock.POSIX (getPOSIXTime)-import Data.Time.Clock (getCurrentTime, diffUTCTime)-import Data.Unique (hashUnique, newUnique)-import Data.Conduit (Conduit, Sink, awaitForever, yield, ($$), ($=))-import Data.Conduit.TMChan (sourceTBMChan)-import qualified Data.Conduit.Binary as CB (take)-import qualified Data.ByteString.Char8 as C (pack)-import qualified Data.ByteString as BS (ByteString, null, append)-import qualified Data.ByteString.Lazy as BL (toStrict)-import Data.String.Conversions (cs)-import qualified Data.Map as M- ( keys , lookup, assocs, elems, fromList, unionWith )-import Data.Conduit.Network- ( runGeneralTCPClient, appSink, appSource, clientSettings )--import qualified Database.LevelDB.Base as L (DB, withDB)--import Network.Socket (SockAddr (SockAddrInet))--import Network.Haskoin.Node-import Network.Haskoin.Node.STM-import Network.Haskoin.Node.HeaderTree-import Network.Haskoin.Transaction-import Network.Haskoin.Block-import Network.Haskoin.Constants-import Network.Haskoin.Util+import Control.Concurrent (killThread, myThreadId,+ threadDelay)+import Control.Concurrent.Async.Lifted (link, race, waitAnyCancel,+ waitCatch, withAsync)+import Control.Concurrent.STM (STM, atomically, modifyTVar',+ newTVarIO, readTVar, retry,+ swapTVar)+import Control.Concurrent.STM.TBMChan (TBMChan, closeTBMChan,+ newTBMChan, writeTBMChan)+import Control.Exception.Lifted (finally, fromException, throw,+ throwIO)+import Control.Monad (forM_, forever, join, unless,+ when)+import Control.Monad.Logger (MonadLoggerIO, logDebug,+ logError, logInfo, logWarn)+import Control.Monad.Reader (asks)+import Control.Monad.State (StateT, evalStateT, get, put)+import Control.Monad.Trans (MonadIO, lift, liftIO)+import Control.Monad.Trans.Control (MonadBaseControl)+import Data.Bits (testBit)+import qualified Data.ByteString as BS (ByteString, append,+ null)+import qualified Data.ByteString.Char8 as C (pack)+import qualified Data.ByteString.Lazy as BL (toStrict)+import Data.Conduit (Conduit, Sink, awaitForever,+ yield, ($$), ($=))+import qualified Data.Conduit.Binary as CB (take)+import Data.Conduit.Network (appSink, appSource,+ clientSettings,+ runGeneralTCPClient)+import Data.Conduit.TMChan (sourceTBMChan)+import Data.List (nub, sort, sortBy)+import qualified Data.Map as M (assocs, elems, fromList,+ keys, lookup, unionWith)+import Data.Maybe (fromMaybe, isJust,+ listToMaybe)+import Data.String.Conversions (cs)+import Data.Text (Text, pack)+import Data.Time.Clock (diffUTCTime, getCurrentTime)+import Data.Time.Clock.POSIX (getPOSIXTime)+import Data.Unique (hashUnique, newUnique)+import Data.Word (Word32)+import Network.Haskoin.Block+import Network.Haskoin.Constants+import Network.Haskoin.Node+import Network.Haskoin.Node.HeaderTree+import Network.Haskoin.Node.STM+import Network.Haskoin.Transaction+import Network.Haskoin.Util+import Network.Socket (SockAddr (SockAddrInet))+import System.Random (randomIO) -- TODO: Move constants elsewhere ? minProtocolVersion :: Word32@@ -56,7 +60,7 @@ -- Start a reconnecting peer that will idle once the connection is established -- and the handshake is performed.-startPeer :: (MonadIO m, MonadLogger m, MonadBaseControl IO m)+startPeer :: (MonadLoggerIO m, MonadBaseControl IO m) => PeerHost -> NodeT m () startPeer ph@PeerHost{..} = do@@ -69,7 +73,7 @@ -- reconnections are performed using an expoential backoff time. This function -- blocks until the peer cannot reconnect (either the peer is banned or we -- already have a peer connected to the given peer host).-startReconnectPeer :: (MonadIO m, MonadLogger m, MonadBaseControl IO m)+startReconnectPeer :: (MonadLoggerIO m, MonadBaseControl IO m) => PeerHost -> NodeT m () startReconnectPeer ph@PeerHost{..} = do@@ -116,7 +120,7 @@ -- Start a peer with with the given peer host/peer id and initiate the -- network protocol handshake. This function will block until the peer -- connection is closed or an exception is raised.-startPeerPid :: (MonadIO m, MonadLogger m, MonadBaseControl IO m)+startPeerPid :: (MonadLoggerIO m, MonadBaseControl IO m) => PeerId -> PeerHost -> NodeT m ()@@ -237,7 +241,7 @@ -- message queue for processing. If we receive invalid messages, this function -- will also notify the PeerManager about a misbehaving remote host. decodeMessage- :: (MonadLogger m, MonadIO m, MonadBaseControl IO m)+ :: (MonadLoggerIO m, MonadBaseControl IO m) => PeerId -> PeerHost -> Sink BS.ByteString (StateT (Maybe (MerkleBlock, MerkleTxs)) (NodeT m)) ()@@ -264,7 +268,7 @@ decodeMessage pid ph -- Handle a message from a peer-processMessage :: (MonadLogger m, MonadIO m, MonadBaseControl IO m)+processMessage :: (MonadLoggerIO m, MonadBaseControl IO m) => PeerId -> PeerHost -> Message@@ -273,7 +277,7 @@ MVersion v -> lift $ do $(logDebug) $ formatPid pid ph "Processing MVersion message" join . atomicallyNodeT $ do- oldVerM <- liftM peerSessionVersion $ getPeerSession pid+ oldVerM <- peerSessionVersion <$> getPeerSession pid case oldVerM of Just _ -> do _ <- trySendMessage pid $ MReject $ reject@@ -350,6 +354,9 @@ [ "Received valid merkle block" , cs $ blockHashToHex $ headerHash mHead ]+ forM_ mTxs $ \h ->+ $(logDebug) $ formatPid pid ph $ unwords+ [ "Matched merkle tx:", cs $ txHashToHex h ] if null mTxs -- Deliver the merkle block then lift . atomicallyNodeT $ do@@ -373,7 +380,7 @@ isTxMsg (MTx _) = True isTxMsg _ = False -processInvMessage :: (MonadLogger m, MonadIO m, MonadBaseControl IO m)+processInvMessage :: (MonadLoggerIO m, MonadBaseControl IO m) => PeerId -> PeerHost -> Inv@@ -410,21 +417,24 @@ blocklist = map (BlockHash . invHash) $ filter ((== InvBlock) . invType) vs -- | Encode message that are being sent to the remote host.-encodeMessage :: (MonadIO m, MonadLogger m)+encodeMessage :: MonadLoggerIO m => Conduit Message (NodeT m) BS.ByteString encodeMessage = awaitForever $ yield . encode' -peerPing :: (MonadIO m, MonadLogger m, MonadBaseControl IO m)+peerPing :: (MonadLoggerIO m, MonadBaseControl IO m) => PeerId -> PeerHost -> NodeT m () peerPing pid ph = forever $ do+ $(logDebug) $ formatPid pid ph+ "Waiting until the peer is available for sending pings..."+ atomicallyNodeT $ waitPeerAvailable pid+ nonce <- liftIO randomIO- (nonceTVar, busy) <- atomicallyNodeT $ do- busy <- isPeerBusy pid+ nonceTVar <- atomicallyNodeT $ do PeerSession{..} <- getPeerSession pid sendMessage pid $ MPing $ Ping nonce- return (peerSessionPings, busy)+ return peerSessionPings $(logDebug) $ formatPid pid ph $ unwords [ "Waiting for Ping nonce", show nonce ]@@ -438,10 +448,9 @@ PeerSession{..} <- getPeerSession pid -- Compute the ping time and the new score let diff = diffUTCTime endTime startTime- score = 0.5*diff + 0.5*(fromMaybe diff peerSessionScore)+ score = 0.5 * diff + 0.5 * fromMaybe diff peerSessionScore -- Save the score in the peer session unless the peer is busy- unless busy $ modifyPeerSession pid $- \s -> s{ peerSessionScore = Just score }+ modifyPeerSession pid $ \s -> s{ peerSessionScore = Just score } return (diff, score) $(logDebug) $ formatPid pid ph $ unwords [ "Got response to ping", show nonce@@ -457,7 +466,7 @@ ns <- liftIO . atomically $ do ns <- swapTVar nonceTVar [] if null ns then retry else return ns- if nonce `elem` ns then return () else waitPong nonce nonceTVar+ unless (nonce `elem` ns) $ waitPong nonce nonceTVar killPeer nonce = do $(logWarn) $ formatPid pid ph $ concat [ "Did not receive a timely reply for Ping ", show nonce@@ -465,7 +474,10 @@ ] disconnectPeer pid ph -peerHandshake :: (MonadIO m, MonadLogger m, MonadBaseControl IO m)+isBloomDisabled :: Version -> Bool+isBloomDisabled ver = version ver >= 70011 && not (services ver `testBit` 2)++peerHandshake :: (MonadLoggerIO m, MonadBaseControl IO m) => PeerId -> PeerHost -> TBMChan Message@@ -487,44 +499,49 @@ , unwords [ " time :", show $ timestamp peerVer ] , unwords [ " blocks :", show $ startHeight peerVer ] ]- -- Check the protocol version- if version peerVer < minProtocolVersion- then misbehaving pid ph severeDoS $ unwords- [ "Connected to a peer speaking protocol version"- , show $ version peerVer- , "but we require at least"- , show $ minProtocolVersion- ]- else do- atomicallyNodeT $ do- -- Save the peers height and update the network height- modifyPeerSession pid $ \s ->- s{ peerSessionHeight = startHeight peerVer- , peerSessionConnected = True- }- updateNetworkHeight- -- Reset the reconnection timer (exponential backoff)- modifyHostSession ph $ \s -> s{ peerHostSessionReconnect = 1 }- -- ACK the version message- lift $ writeTBMChan chan MVerAck - $(logDebug) $ formatPid pid ph "Handshake complete"+ -- Check the protocol version+ go peerVer $ do+ atomicallyNodeT $ do+ -- Save the peers height and update the network height+ modifyPeerSession pid $ \s ->+ s{ peerSessionHeight = startHeight peerVer+ , peerSessionConnected = True+ }+ updateNetworkHeight+ -- Reset the reconnection timer (exponential backoff)+ modifyHostSession ph $ \s ->+ s{ peerHostSessionReconnect = 1 }+ -- ACK the version message+ lift $ writeTBMChan chan MVerAck+ $(logDebug) $ formatPid pid ph "Handshake complete" where+ go ver action+ | version ver < minProtocolVersion =+ misbehaving pid ph severeDoS $ unwords+ [ "Connected to a peer speaking protocol version"+ , show $ version ver+ , "but we require at least"+ , show minProtocolVersion+ ]+ | isBloomDisabled ver =+ misbehaving pid ph severeDoS "Peer does not support bloom filters"+ | otherwise = action buildVersion = do -- TODO: Get our correct IP here let add = NetworkAddress 1 $ SockAddrInet 0 0 ua = VarString haskoinUserAgent- time <- liftM floor $ liftIO getPOSIXTime+ time <- floor <$> liftIO getPOSIXTime rdmn <- liftIO randomIO -- nonce- h <- runHeaderTree bestBlockHeaderHeight- return Version { version = 70001- , services = 1+ height <- nodeBlockHeight <$> atomicallyNodeT (readTVarS sharedBestHeader)+ return Version { version = 70011+ , services = 5 , timestamp = time , addrRecv = add , addrSend = add , verNonce = rdmn , userAgent = ua- , startHeight = h+ , startHeight = height , relay = False } @@ -538,7 +555,7 @@ -- Delete the session of a peer and send a kill signal to the peers thread. -- Unless the peer is banned, the peer will try to reconnect.-disconnectPeer :: (MonadIO m, MonadLogger m)+disconnectPeer :: (MonadLoggerIO m) => PeerId -> PeerHost -> NodeT m ()@@ -552,12 +569,12 @@ {- Peer utility functions -} --- Is the peer busy?-isPeerBusy :: PeerId -> NodeT STM Bool-isPeerBusy pid = do+--- Wait until the given peer is not syncing headers or merkle blocks+waitPeerAvailable :: PeerId -> NodeT STM ()+waitPeerAvailable pid = do hPidM <- readTVarS sharedHeaderPeer mPidM <- readTVarS sharedMerklePeer- return $ Just pid `elem` [hPidM, mPidM]+ when (Just pid `elem` [hPidM, mPidM]) $ lift retry -- Wait for a non-empty bloom filter to be available waitBloomFilter :: NodeT STM BloomFilter@@ -576,7 +593,7 @@ -- Returns the median height of all the peers getMedianHeight :: NodeT STM BlockHeight getMedianHeight = do- hs <- liftM (map (peerSessionHeight . snd)) getConnectedPeers+ hs <- map (peerSessionHeight . snd) <$> getConnectedPeers let (_,ms) = splitAt (length hs `div` 2) $ sort hs return $ fromMaybe 0 $ listToMaybe ms @@ -589,10 +606,10 @@ peerMap <- readTVarS sharedPeerMap lift $ mapM f $ M.assocs peerMap where- f (pid, sess) = liftM ((,) pid) $ readTVar sess+ f (pid, sess) = (,) pid <$> readTVar sess getConnectedPeers :: NodeT STM [(PeerId, PeerSession)]-getConnectedPeers = liftM (filter (peerSessionConnected . snd)) getPeers+getConnectedPeers = filter (peerSessionConnected . snd) <$> getPeers -- Returns a peer that is connected, at the network height and -- with the best score.@@ -606,7 +623,7 @@ getPeersAtHeight :: (BlockHeight -> Bool) -> NodeT STM [(PeerId, PeerSession)] getPeersAtHeight cmpHeight = do- peers <- liftM (filter f) getPeers+ peers <- filter f <$> getPeers -- Choose the peer with the best score return $ sortBy s peers where@@ -635,7 +652,7 @@ PeerSession{..} <- getPeerSession pid if peerSessionConnected then lift $ writeTBMChan peerSessionChan msg- else throw $ NodeExceptionPeerNotConnected pid+ else throw $ NodeExceptionPeerNotConnected $ ShowPeerId pid -- Send a message to all connected peers. sendMessageAll :: Message -> NodeT STM ()@@ -646,7 +663,7 @@ getNetworkHeight :: NodeT STM BlockHeight getNetworkHeight = readTVarS sharedNetworkHeight -misbehaving :: (MonadIO m, MonadLogger m)+misbehaving :: (MonadLoggerIO m) => PeerId -> PeerHost -> (PeerHostScore -> PeerHostScore)@@ -656,7 +673,7 @@ sessM <- atomicallyNodeT $ do modifyHostSession ph $ \s -> s{ peerHostSessionScore = f $! peerHostSessionScore s- , peerHostSessionLog = msg:(peerHostSessionLog s)+ , peerHostSessionLog = msg : peerHostSessionLog s } getHostSession ph case sessM of@@ -670,14 +687,10 @@ disconnectPeer pid ph _ -> return () -{- LevelDB function -}+{- Run header tree database action -} -runHeaderTree :: MonadIO m => ReaderT L.DB IO a -> NodeT m a-runHeaderTree action = do- lock <- asks sharedLevelDBLock- fp <- asks levelDBFilePath- opts <- asks levelDBOptions- liftIO $ Lock.with lock $ L.withDB fp opts $ runReaderT action+-- runHeaderTree :: MonadIO m => ReaderT L.DB IO a -> NodeT m a+-- runHeaderTree action = undefined {- Utilities -} @@ -693,7 +706,7 @@ resE <- race (liftIO $ threadDelay (sec * 1000000)) action case resE of Right res -> return $ Right res- Left _ -> liftM Left cleanup+ Left _ -> fmap Left cleanup formatPid :: PeerId -> PeerHost -> String -> Text formatPid pid ph str = pack $ concat
Network/Haskoin/Node/STM.hs view
@@ -1,43 +1,46 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-} module Network.Haskoin.Node.STM where -import Control.Monad (liftM, (<=<))-import Control.Monad.Trans (MonadIO, lift, liftIO)-import Control.Monad.Reader (ReaderT, ask, asks, runReaderT)-import Control.Monad.Trans.Control (MonadBaseControl)-import Control.Monad.Logger (MonadLogger, logDebug)-import Control.Concurrent (ThreadId)-import Control.Concurrent.STM.Lock (Lock)-import Control.DeepSeq (NFData(..))-import qualified Control.Concurrent.STM.Lock as Lock (new)-import Control.Concurrent.STM.TBMChan- (TBMChan, closeTBMChan, newTBMChan)-import Control.Exception.Lifted- (SomeException, Exception, fromException, throw, catch)-import Control.Concurrent.STM- ( STM, TMVar, TVar, atomically, orElse- , readTVar, writeTVar, newTVarIO, modifyTVar', newTVar- , tryPutTMVar, takeTMVar, newEmptyTMVarIO, isEmptyTMVar, putTMVar- , tryReadTMVar, readTMVar- )--import Data.Time.Clock (NominalDiffTime)-import Data.Unique (Unique, hashUnique)-import Data.Typeable (Typeable)-import Data.Word (Word32, Word64)-import Data.Maybe (isJust)-import Data.Aeson.TH (deriveJSON)-import qualified Data.Map.Strict as M (Map, insert, lookup, delete, empty)--import qualified Database.LevelDB.Base as L (Options(..), withDB)--import Network.Haskoin.Util-import Network.Haskoin.Node-import Network.Haskoin.Block-import Network.Haskoin.Transaction-import Network.Haskoin.Constants-import Network.Haskoin.Node.HeaderTree+import Control.Concurrent (ThreadId)+import Control.Concurrent.STM (STM, TMVar, TVar, atomically,+ isEmptyTMVar, modifyTVar',+ newEmptyTMVarIO, newTVar,+ newTVarIO, orElse, putTMVar,+ readTMVar, readTVar,+ takeTMVar, tryPutTMVar,+ tryReadTMVar, writeTVar)+import Control.Concurrent.STM.Lock (Lock)+import qualified Control.Concurrent.STM.Lock as Lock (new)+import Control.Concurrent.STM.TBMChan (TBMChan, closeTBMChan,+ newTBMChan)+import Control.DeepSeq (NFData (..))+import Control.Exception.Lifted (Exception, SomeException,+ catch, fromException, throw)+import Control.Monad ((<=<))+import Control.Monad.Logger (MonadLoggerIO, logDebug)+import Control.Monad.Reader (ReaderT, ask, asks,+ runReaderT)+import Control.Monad.Trans (MonadIO, lift, liftIO)+import Control.Monad.Trans.Control (MonadBaseControl)+import Data.Aeson.TH (deriveJSON)+import qualified Data.Map.Strict as M (Map, delete, empty,+ insert, lookup)+import Data.Maybe (isJust)+import Data.Time.Clock (NominalDiffTime)+import Data.Typeable (Typeable)+import Data.Unique (Unique, hashUnique)+import Data.Word (Word32, Word64)+import Database.Persist.Sql (ConnectionPool, SqlBackend,+ SqlPersistT, runSqlConn,+ runSqlPool)+import Network.Haskoin.Block+import Network.Haskoin.Node+import Network.Haskoin.Node.HeaderTree+import Network.Haskoin.Transaction+import Network.Haskoin.Util {- Type aliases -} @@ -46,49 +49,56 @@ type PeerId = Unique type PeerHostScore = Word32 -instance Show PeerId where- show = show . hashUnique+newtype ShowPeerId = ShowPeerId { getShowPeerId :: PeerId }+ deriving (Eq) -getNodeState :: (MonadIO m, MonadLogger m)- => FilePath- -> L.Options+instance Show ShowPeerId where+ show = show . hashUnique . getShowPeerId++runSql :: (MonadBaseControl IO m)+ => SqlPersistT m a+ -> Either SqlBackend ConnectionPool+ -> m a+runSql f (Left conn) = runSqlConn f conn+runSql f (Right pool) = runSqlPool f pool++runSqlNodeT :: (MonadBaseControl IO m) => SqlPersistT m a -> NodeT m a+runSqlNodeT f = asks sharedSqlBackend >>= lift . runSql f++getNodeState :: (MonadLoggerIO m, MonadBaseControl IO m)+ => Either SqlBackend ConnectionPool -> m SharedNodeState-getNodeState levelDBFilePath levelDBOptions = do+getNodeState sharedSqlBackend = do -- Initialize the HeaderTree $(logDebug) "Initializing the HeaderTree and NodeState"+ best <- runSql (initHeaderTree >> getBestBlock) sharedSqlBackend liftIO $ do- L.withDB levelDBFilePath levelDBOptions $ runReaderT initHeaderTree- sharedPeerMap <- newTVarIO M.empty- sharedHostMap <- newTVarIO M.empty- sharedNetworkHeight <- newTVarIO 0- sharedHeaders <- newEmptyTMVarIO- sharedHeaderPeer <- newTVarIO Nothing- sharedMerklePeer <- newTVarIO Nothing- sharedSyncLock <- atomically Lock.new- sharedTickleChan <- atomically $ newTBMChan 1024- sharedTxChan <- atomically $ newTBMChan 1024- sharedTxGetData <- newTVarIO M.empty- sharedRescan <- newEmptyTMVarIO- sharedMempool <- newTVarIO False- sharedLevelDBLock <- atomically Lock.new- sharedBloomFilter <- newTVarIO Nothing+ sharedPeerMap <- newTVarIO M.empty+ sharedHostMap <- newTVarIO M.empty+ sharedNetworkHeight <- newTVarIO 0+ sharedHeaders <- newEmptyTMVarIO+ sharedHeaderPeer <- newTVarIO Nothing+ sharedMerklePeer <- newTVarIO Nothing+ sharedSyncLock <- atomically Lock.new+ sharedTickleChan <- atomically $ newTBMChan 1024+ sharedTxChan <- atomically $ newTBMChan 1024+ sharedTxGetData <- newTVarIO M.empty+ sharedRescan <- newEmptyTMVarIO+ sharedMempool <- newTVarIO False+ sharedBloomFilter <- newTVarIO Nothing -- Find our best node in the HeaderTree- sharedBestHeader <- newTVarIO =<< L.withDB- levelDBFilePath- levelDBOptions- (runReaderT getBestBlockHeader)- sharedBestBlock <- newTVarIO $ headerHash genesisHeader+ sharedBestHeader <- newTVarIO best+ sharedBestBlock <- newTVarIO genesisBlock return SharedNodeState{..} -runNodeT :: Monad m => SharedNodeState -> NodeT m a -> m a-runNodeT state action = runReaderT action state+runNodeT :: Monad m => NodeT m a -> SharedNodeState -> m a+runNodeT = runReaderT -withNodeT :: (MonadIO m, MonadLogger m)- => FilePath- -> L.Options- -> NodeT m a+withNodeT :: (MonadLoggerIO m, MonadBaseControl IO m)+ => NodeT m a+ -> Either SqlBackend ConnectionPool -> m a-withNodeT fp opts action = flip runNodeT action =<< getNodeState fp opts+withNodeT action sql = runNodeT action =<< getNodeState sql atomicallyNodeT :: MonadIO m => NodeT STM a -> NodeT m a atomicallyNodeT action = liftIO . atomically . runReaderT action =<< ask@@ -111,42 +121,37 @@ {- Shared Peer STM Type -} data SharedNodeState = SharedNodeState- { sharedPeerMap :: !(TVar (M.Map PeerId (TVar PeerSession)))+ { sharedPeerMap :: !(TVar (M.Map PeerId (TVar PeerSession))) -- ^ Map of all active peers and their sessions- , sharedHostMap :: !(TVar (M.Map PeerHost (TVar PeerHostSession)))+ , sharedHostMap :: !(TVar (M.Map PeerHost (TVar PeerHostSession))) -- ^ The peer that is currently syncing the block headers , sharedNetworkHeight :: !(TVar BlockHeight) -- ^ The current height of the network- , sharedHeaders :: !(TMVar (PeerId, Headers))+ , sharedHeaders :: !(TMVar (PeerId, Headers)) -- ^ Block headers sent from a peer- , sharedHeaderPeer :: !(TVar (Maybe PeerId))+ , sharedHeaderPeer :: !(TVar (Maybe PeerId)) -- ^ Peer currently syncing headers- , sharedMerklePeer :: !(TVar (Maybe PeerId))+ , sharedMerklePeer :: !(TVar (Maybe PeerId)) -- ^ Peer currently downloading merkle blocks- , sharedSyncLock :: !Lock+ , sharedSyncLock :: !Lock -- ^ Lock on the header syncing process- , sharedLevelDBLock :: !Lock- -- ^ LevelDB lock- , sharedBestHeader :: !(TVar BlockHeaderNode)+ , sharedBestHeader :: !(TVar NodeBlock) -- ^ Our best block header- , sharedBestBlock :: !(TVar BlockHash)- -- ^ Our best merkle block- , sharedTxGetData :: !(TVar (M.Map TxHash [(PeerId, PeerHost)]))+ , sharedBestBlock :: !(TVar NodeBlock)+ -- ^ Our best merkle block's height+ , sharedTxGetData :: !(TVar (M.Map TxHash [(PeerId, PeerHost)])) -- ^ List of Tx GetData requests- , sharedBloomFilter :: !(TVar (Maybe (BloomFilter, Int)))+ , sharedBloomFilter :: !(TVar (Maybe (BloomFilter, Int))) -- ^ Bloom filter- , sharedTickleChan :: !(TBMChan (PeerId, PeerHost, BlockHash))+ , sharedTickleChan :: !(TBMChan (PeerId, PeerHost, BlockHash)) -- ^ Channel containing all the block tickles received from peers- , sharedTxChan :: !(TBMChan (PeerId, PeerHost, Tx))+ , sharedTxChan :: !(TBMChan (PeerId, PeerHost, Tx)) -- ^ Transaction channel- , sharedRescan :: !(TMVar (Either Timestamp BlockHeight))+ , sharedRescan :: !(TMVar (Either Timestamp BlockHeight)) -- ^ Rescan requests from a timestamp or from a block height- , sharedMempool :: !(TVar Bool)+ , sharedMempool :: !(TVar Bool) -- ^ Did we do a Mempool sync ?- , levelDBFilePath :: !FilePath- -- ^ LevelDB FilePath- , levelDBOptions :: !L.Options- -- ^ LevelDB Options+ , sharedSqlBackend :: !(Either SqlBackend ConnectionPool) } {- Peer Data -}@@ -155,23 +160,23 @@ -- Data stored about a peer data PeerSession = PeerSession- { peerSessionConnected :: !Bool+ { peerSessionConnected :: !Bool -- ^ True if the peer is connected (completed the handshake)- , peerSessionVersion :: !(Maybe Version)+ , peerSessionVersion :: !(Maybe Version) -- ^ Contains the version message that we received from the peer- , peerSessionHeight :: !BlockHeight+ , peerSessionHeight :: !BlockHeight -- ^ Current known height of the peer- , peerSessionChan :: !(TBMChan Message)+ , peerSessionChan :: !(TBMChan Message) -- ^ Message channel to send messages to the peer- , peerSessionHost :: !PeerHost+ , peerSessionHost :: !PeerHost -- ^ Host to which this peer is connected- , peerSessionThreadId :: !ThreadId+ , peerSessionThreadId :: !ThreadId -- ^ Peer ThreadId- , peerSessionMerkleChan :: !(TBMChan (Either (MerkleBlock, MerkleTxs) Tx))+ , peerSessionMerkleChan :: !(TBMChan (Either (MerkleBlock, MerkleTxs) Tx)) -- ^ Merkle block/Merkle transaction channel- , peerSessionPings :: !(TVar [PingNonce])+ , peerSessionPings :: !(TVar [PingNonce]) -- ^ Time at which we requested pings- , peerSessionScore :: !(Maybe NominalDiffTime)+ , peerSessionScore :: !(Maybe NominalDiffTime) -- ^ Ping scores for this peer (round trip times) } @@ -215,7 +220,6 @@ , peerStatusPing :: !(Maybe String) , peerStatusDoSScore :: !(Maybe PeerHostScore) -- Debug fields- , peerStatusThreadId :: !String , peerStatusHaveMerkles :: !Bool , peerStatusHaveMessage :: !Bool , peerStatusPingNonces :: ![PingNonce]@@ -232,6 +236,7 @@ , nodeStatusBestHeader :: !BlockHash , nodeStatusBestHeaderHeight :: !BlockHeight , nodeStatusBestBlock :: !BlockHash+ , nodeStatusBestBlockHeight :: !BlockHeight , nodeStatusBloomSize :: !Int -- Debug fields , nodeStatusHeaderPeer :: !(Maybe Int)@@ -243,7 +248,6 @@ , nodeStatusRescan :: !(Maybe (Either Timestamp BlockHeight)) , nodeStatusMempool :: !Bool , nodeStatusSyncLock :: !Bool- , nodeStatusLevelDBLock :: !Bool } $(deriveJSON (dropFieldLabel 10) ''NodeStatus)@@ -254,7 +258,7 @@ tryGetPeerSession pid = do peerMap <- readTVarS sharedPeerMap case M.lookup pid peerMap of- Just sessTVar -> liftM Just $ lift $ readTVar sessTVar+ Just sessTVar -> fmap Just $ lift $ readTVar sessTVar _ -> return Nothing getPeerSession :: PeerId -> NodeT STM PeerSession@@ -262,7 +266,7 @@ sessM <- tryGetPeerSession pid case sessM of Just sess -> return sess- _ -> throw $ NodeExceptionInvalidPeer pid+ _ -> throw $ NodeExceptionInvalidPeer $ ShowPeerId pid newPeerSession :: PeerId -> PeerSession -> NodeT STM () newPeerSession pid sess = do@@ -303,7 +307,7 @@ getHostSession ph = do hostMap <- readTVarS sharedHostMap lift $ case M.lookup ph hostMap of- Just hostSessionTVar -> liftM Just $ readTVar hostSessionTVar+ Just hostSessionTVar -> Just <$> readTVar hostSessionTVar _ -> return Nothing modifyHostSession :: PeerHost@@ -352,7 +356,7 @@ orElseNodeT :: NodeT STM a -> NodeT STM a -> NodeT STM a orElseNodeT a b = do s <- ask- lift $ (runNodeT s a) `orElse` (runNodeT s b)+ lift $ runNodeT a s `orElse` runNodeT b s {- TVar Utilities -} @@ -360,7 +364,7 @@ readTVarS = lift . readTVar <=< asks writeTVarS :: (SharedNodeState -> TVar a) -> a -> NodeT STM ()-writeTVarS f val = lift . (flip writeTVar val) =<< asks f+writeTVarS f val = lift . flip writeTVar val =<< asks f {- TMVar Utilities -} @@ -374,13 +378,13 @@ tryReadTMVarS = lift . tryReadTMVar <=< asks putTMVarS :: (SharedNodeState -> TMVar a) -> a -> NodeT STM ()-putTMVarS f val = lift . (flip putTMVar val) =<< asks f+putTMVarS f val = lift . flip putTMVar val =<< asks f tryPutTMVarS :: (SharedNodeState -> TMVar a) -> a -> NodeT STM Bool-tryPutTMVarS f val = lift . (flip tryPutTMVar val) =<< asks f+tryPutTMVarS f val = lift . flip tryPutTMVar val =<< asks f swapTMVarS :: (SharedNodeState -> TMVar a) -> a -> NodeT STM ()-swapTMVarS f val = lift . (flip putTMVar val) =<< asks f+swapTMVarS f val = lift . flip putTMVar val =<< asks f isEmptyTMVarS :: (SharedNodeState -> TMVar a) -> NodeT STM Bool isEmptyTMVarS f = lift . isEmptyTMVar =<< asks f@@ -388,8 +392,8 @@ data NodeException = NodeExceptionBanned | NodeExceptionConnected- | NodeExceptionInvalidPeer !PeerId- | NodeExceptionPeerNotConnected !PeerId+ | NodeExceptionInvalidPeer !ShowPeerId+ | NodeExceptionPeerNotConnected !ShowPeerId | NodeException !String deriving (Show, Typeable)
haskoin-node.cabal view
@@ -1,5 +1,5 @@ name: haskoin-node-version: 0.2.0+version: 0.3.0 synopsis: Implementation of a Bitoin node. description:@@ -19,6 +19,7 @@ homepage: http://github.com/haskoin/haskoin bug-reports: http://github.com/haskoin/haskoin/issues+tested-with: GHC==7.10.3, GHC==7.10.2, GHC==7.10.1 stability: stable license: PublicDomain license-file: UNLICENSE@@ -27,7 +28,6 @@ category: Bitcoin, Finance, Network build-type: Simple cabal-version: >= 1.9.2-extra-source-files: stack.yaml source-repository head type: git@@ -39,6 +39,8 @@ Network.Haskoin.Node.Peer Network.Haskoin.Node.BlockChain Network.Haskoin.Node.STM+ other-modules: Network.Haskoin.Node.HeaderTree.Types+ Network.Haskoin.Node.HeaderTree.Model extensions: OverloadedStrings FlexibleInstances@@ -46,10 +48,10 @@ RecordWildCards DeriveDataTypeable - build-depends: aeson >= 0.7 && < 0.9- , async >= 2.0 && < 2.1+ build-depends: aeson >= 0.7 && < 0.12+ , async >= 2.0 && < 2.2 , base >= 4.8 && < 5- , binary >= 0.7 && < 0.8+ , binary >= 0.7 && < 0.9 , bytestring >= 0.10 && < 0.11 , concurrent-extra >= 0.7 && < 0.8 , conduit >= 1.2 && < 1.3@@ -58,24 +60,28 @@ , data-default >= 0.5 && < 0.6 , deepseq >= 1.4 && < 1.5 , either >= 4.3 && < 4.5+ , esqueleto >= 2.4 && < 2.5 , exceptions >= 0.8 && < 0.9- , haskoin-core >= 0.2 && < 0.3- , leveldb-haskell >= 0.6 && < 0.7- , lifted-async >= 0.2 && < 0.8+ , haskoin-core >= 0.3 && < 0.5+ , largeword >= 1.2.4 && < 1.3+ , lifted-async >= 0.2 && < 0.9 , lifted-base >= 0.2 && < 0.3 , monad-control >= 1.0 && < 1.1 , monad-logger >= 0.3 && < 0.4 , mtl >= 2.2 && < 2.3 , network >= 2.4 && < 2.7+ , persistent >= 2.2 && < 2.3+ , persistent-template >= 2.1 && < 2.2+ , resource-pool >= 0.2 && < 0.3 , random >= 1.0 && < 1.2 , stm >= 2.4 && < 2.5 , stm-chans >= 3.0 && < 3.1- , stm-conduit >= 2.5 && < 2.7+ , stm-conduit >= 2.5 && < 2.8 , string-conversions >= 0.4 && < 0.5 , text >= 0.11 && < 1.3- , time >= 1.4 && < 1.6+ , time >= 1.4 && < 1.7 - ghc-options: -Wall+ ghc-options: -Wall test-suite test-haskoin-node type: exitcode-stdio-1.0@@ -87,13 +93,18 @@ Network.Haskoin.Node.Units build-depends: base >= 4.8 && < 5+ , haskoin-core , haskoin-node- , HUnit >= 1.2 && < 1.3+ , HUnit >= 1.2 && < 1.4 , QuickCheck >= 2.6 && < 2.9+ , monad-logger >= 0.3 && < 0.4+ , mtl >= 2.2 && < 2.3+ , persistent >= 2.2 && < 2.3+ , persistent-sqlite >= 2.2 && < 2.3+ , resourcet >= 1.1 && < 1.2 , test-framework >= 0.8 && < 0.9 , test-framework-quickcheck2 >= 0.3 && < 0.4 , test-framework-hunit >= 0.3 && < 0.4 ghc-options: -Wall hs-source-dirs: tests-
− stack.yaml
@@ -1,14 +0,0 @@-flags: {}-packages:-- '.'-- '../haskoin-core'-- location:- git: https://github.com/haskoin/secp256k1.git- commit: 5ee603061b3c1eaf2943e8d2c08e6effe85f38e7- extra-dep: true-extra-deps:-- leveldb-haskell-0.6.3-- murmur3-1.0.0-- pbkdf-1.1.1.1-- largeword-1.2.4-resolver: lts-3.4
tests/Network/Haskoin/Node/Units.hs view
@@ -1,17 +1,254 @@-module Network.Haskoin.Node.Units (tests) where---- import Test.HUnit (Assertion, assertBool)-import Test.Framework (Test, testGroup)--- import Test.Framework.Providers.HUnit (testCase)+{-# LANGUAGE OverloadedStrings #-}+module Network.Haskoin.Node.Units where+import Control.Monad (forM_, when)+import Control.Monad.Logger (NoLoggingT)+import Control.Monad.Trans (MonadIO, liftIO)+import Control.Monad.Trans.Resource (ResourceT)+import Data.Maybe (fromJust, isNothing,+ maybeToList)+import Data.Word (Word32)+import Database.Persist.Sqlite (SqlPersistT,+ runMigrationSilent, runSqlite)+import Network.Haskoin.Block+import Network.Haskoin.Constants+import Network.Haskoin.Node.HeaderTree+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (Assertion, assertBool,+ assertEqual, assertFailure) -- TODO: Make sure that evalNewChain for a partially overlapping best chain -- properly evaluates to BestChain. +type App = SqlPersistT (NoLoggingT (ResourceT IO))+ tests :: [Test] tests =- [ testGroup "Test Group"- [+ [ testGroup "Header Tree"+ [ testCase "Initalization successful" $ runUnit initialize+ , testCase "Add second block" $ runUnit addSecondBlock+ , testCase "Blockchain head correct" $ runUnit blockChainHead+ , testCase "Find fork node" $ runUnit forkNode+ , testCase "Find fork node (non-head)" $ runUnit forkNodeNonHead+ , testCase "Find fork node (same chain)" $ runUnit forkNodeSameChain+ , testCase "Get best chain" $ runUnit getBestChain+ , testCase "Get side chain" $ runUnit getSideChain+ , testCase "Nodes at height" $ runUnit getNodesHeight+ , testCase "Block locator to head" $ runUnit blockLocatorToHead+ , testCase "Block locator to non-head" $ runUnit blockLocatorToNode+ , testCase "Find split node" $ runUnit splitNode ] ] +initialize :: App ()+initialize = do+ initHeaderTree+ bM <- getBlockByHash (headerHash genesisHeader)+ liftIO $ assertEqual "Genesis node in header tree" (Just genesisBlock) bM+ hs <- getHeads+ liftIO $ assertEqual "Genesis node is only head" [genesisBlock] hs+ bh <- getBestBlock+ liftIO $ assertEqual "Genesis node matches best header" genesisBlock bh +addSecondBlock :: App ()+addSecondBlock = do+ initHeaderTree+ let block = head chain0+ liftIO $ assertEqual "Block builds on genesis block"+ (headerHash genesisHeader)+ (nodePrev block)+ putBlock block+ block' <- getBlockByHash $ nodeHash block+ liftIO $ assertEqual "Block can be retrieved" (Just block) block'++blockChainHead :: App ()+blockChainHead = mockBlockChain >> do+ heads <- getHeads+ liftIO $ assertEqual "Heads match"+ [last chain0, last chain1, last chain2, last chain3]+ heads+ bh <- getBestBlock+ liftIO $ assertEqual "Best block has correct hash"+ (nodeHash $ last chain3) (nodeHash bh)+ liftIO $ assertEqual "Best block height is right"+ (nodeBlockHeight $ last chain3) (nodeBlockHeight bh)++forkNode :: App ()+forkNode = mockBlockChain >> do+ let l = last chain2+ r = last chain3+ bn <- splitBlock l r++ liftIO $ assertEqual "Split block are correct"+ (chain0 !! 1) bn++ commonLM <- getBlockByHeight l $ nodeBlockHeight bn+ when (isNothing commonLM) $ liftIO $+ assertFailure "Could not find fork on left side"+ let commonL = fromJust commonLM++ commonRM <- getBlockByHeight r $ nodeBlockHeight bn+ when (isNothing commonRM) $ liftIO $+ assertFailure "Could not find fork on right side"+ let commonR = fromJust commonRM++ firstLM <- getBlockByHeight l (nodeBlockHeight bn + 1)+ when (isNothing firstLM) $ liftIO $+ assertFailure "Could not find fork child on left side"+ let firstL = fromJust firstLM++ firstRM <- getBlockByHeight r (nodeBlockHeight bn + 1)+ when (isNothing firstLM) $ liftIO $+ assertFailure "Could not find fork child on right side"+ let firstR = fromJust firstRM++ liftIO $ assertEqual "Fork node is same in both sides" commonL commonR+ liftIO $ assertEqual "Fork node connect with left side"+ (nodeHash commonL)+ (nodePrev firstL)+ liftIO $ assertEqual "Fork node connect with right side"+ (nodeHash commonR)+ (nodePrev firstR)+ liftIO $ assertBool "After-fork chains diverge" $ firstL /= firstR+ liftIO $ assertEqual "Fork node matches hardcoded one"+ (chain0 !! 1) commonL++forkNodeNonHead :: App ()+forkNodeNonHead = mockBlockChain >> do+ let l = chain2 !! 1+ r = chain1 !! 1+ height <- nodeBlockHeight <$> splitBlock l r+ splitM <- getBlockByHeight l height+ liftIO $ assertEqual "Fork node is correct" (Just $ chain1 !! 1) splitM++forkNodeSameChain :: App ()+forkNodeSameChain = mockBlockChain >> do+ let l = chain3 !! 5+ r = chain3 !! 3+ height <- nodeBlockHeight <$> splitBlock l r+ splitM <- getBlockByHeight r height+ liftIO $ assertEqual "Fork node is correct" (Just $ chain3 !! 3) splitM++getBestChain :: App ()+getBestChain = mockBlockChain >> do+ h <- getBestBlock+ ch <- getBlocksFromHeight h 0 0+ liftIO $ assertEqual "Best chain correct" bch ch+ where+ bch = genesisBlock : take 2 chain0 ++ chain3++getSideChain :: App ()+getSideChain = mockBlockChain >> do+ ch <- getBlocksFromHeight (chain2 !! 1) 0 0+ liftIO $ assertEqual "Side chain correct" sch ch+ where+ sch = genesisBlock :+ take 3 chain0 ++ take 2 chain1 ++ take 2 chain2++getNodesHeight :: App ()+getNodesHeight = mockBlockChain >> do+ ns <- getBlocksAtHeight 3+ liftIO $ assertEqual "Nodes at height match" hns ns+ where+ hns = [chain0 !! 2, head chain3]++blockLocatorToHead :: App ()+blockLocatorToHead = do+ mockBlockChain+ putBlocks bs+ h <- getBestBlock+ liftIO $ assertEqual "Head matches" (last bs) h+ ls <- blockLocator h+ liftIO $ assertEqual "Last is genesis"+ (last ls)+ (headerHash genesisHeader)+ liftIO $ assertEqual "First is current head"+ (head ls)+ (nodeHash h)+ last10 <- map nodeHash . reverse <$>+ getBlocksFromHeight h 0 (nodeBlockHeight h - 9)+ liftIO $ assertEqual "Last ten blocks contiguous"+ last10+ (take 10 ls)+ let h10 = nodeBlockHeight h - 10+ bhs <- map (nodeHash . fromJust) <$>+ mapM (getBlockByHeight h)+ [h10, h10 - 2, h10 - 6, h10 - 14, h10 - 30, h10 - 62]+ liftIO $ assertEqual "All block hashes correct"+ (last10 ++ bhs ++ [headerHash genesisHeader])+ ls+ where+ bs = manyBlocks $ last chain1++blockLocatorToNode :: App ()+blockLocatorToNode = do+ mockBlockChain+ putBlocks bs+ n <- fromJust <$> getBlockByHash (nodeHash $ chain3 !! 4)+ ls <- blockLocator n+ xs <- map nodeHash . reverse <$>+ getBlocksFromHeight n 0 0+ liftIO $ assertEqual "Block locator for non-head node is correct" xs ls+ where+ bs = manyBlocks $ last chain1++splitNode :: App ()+splitNode = do+ mockBlockChain+ (split, ls, rs) <- splitChains (last chain2, 0) (last chain3, 0)+ liftIO $ assertEqual "Split node correct" (chain0 !! 1) split+ liftIO $ assertEqual "Left correct"+ ([chain0 !! 2] ++ take 2 chain1 ++ chain2)+ ls+ liftIO $ assertEqual "Right correct" chain3 rs++runUnit :: App () -> Assertion+runUnit action = runSqlite ":memory:" $ do+ _ <- runMigrationSilent migrateHeaderTree+ action++mockBlockChain :: MonadIO m => SqlPersistT m ()+mockBlockChain = do+ initHeaderTree+ forM_ (concat [chain0, chain1, chain2, chain3]) putBlock++manyBlocks :: NodeBlock -> [NodeBlock]+manyBlocks b =+ tail $ reverse $ foldBlock (Just b) $ zip [18..117] (repeat 4)+++chain0 :: [NodeBlock]+chain0 =+ tail $ reverse $ foldBlock Nothing $ zip [1..4] (repeat 0)++chain1 :: [NodeBlock]+chain1 =+ tail $ reverse $ foldBlock (Just $ chain0 !! 2) $ zip [5..7] (repeat 1)++chain2 :: [NodeBlock]+chain2 =+ tail $ reverse $ foldBlock (Just $ chain1 !! 1) $ zip [8..10] (repeat 2)++chain3 :: [NodeBlock]+chain3 =+ tail $ reverse $ foldBlock (Just $ chain0 !! 1) $ zip [11..17] (repeat 3)++foldBlock :: Maybe NodeBlock -> [(Word32, Word32)] -> [NodeBlock]+foldBlock nM =+ foldl f (maybeToList nM)+ where+ f [] _ = [genesisBlock]+ f ls@(l:_) (n, chain) = mockBlock l chain n : ls++mockBlock :: NodeBlock -> Word32 -> Word32 -> NodeBlock+mockBlock parent chain n = nodeBlock parent chain bh+ where+ bh = BlockHeader+ { blockVersion = blockVersion $ nodeHeader parent+ , prevBlock = nodeHash parent+ , merkleRoot = z+ , blockTimestamp = nodeTimestamp parent + 600+ , blockBits = blockBits $ nodeHeader parent+ , bhNonce = n+ }+ z = "0000000000000000000000000000000000000000000000000000000000000000"