diff --git a/Network/Haskoin/Node/BlockChain.hs b/Network/Haskoin/Node/BlockChain.hs --- a/Network/Haskoin/Node/BlockChain.hs +++ b/Network/Haskoin/Node/BlockChain.hs @@ -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{..} diff --git a/Network/Haskoin/Node/HeaderTree.hs b/Network/Haskoin/Node/HeaderTree.hs --- a/Network/Haskoin/Node/HeaderTree.hs +++ b/Network/Haskoin/Node/HeaderTree.hs @@ -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 diff --git a/Network/Haskoin/Node/HeaderTree/Model.hs b/Network/Haskoin/Node/HeaderTree/Model.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Node/HeaderTree/Model.hs @@ -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 +|] diff --git a/Network/Haskoin/Node/HeaderTree/Types.hs b/Network/Haskoin/Node/HeaderTree/Types.hs new file mode 100644 --- /dev/null +++ b/Network/Haskoin/Node/HeaderTree/Types.hs @@ -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 diff --git a/Network/Haskoin/Node/Peer.hs b/Network/Haskoin/Node/Peer.hs --- a/Network/Haskoin/Node/Peer.hs +++ b/Network/Haskoin/Node/Peer.hs @@ -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 diff --git a/Network/Haskoin/Node/STM.hs b/Network/Haskoin/Node/STM.hs --- a/Network/Haskoin/Node/STM.hs +++ b/Network/Haskoin/Node/STM.hs @@ -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) diff --git a/haskoin-node.cabal b/haskoin-node.cabal --- a/haskoin-node.cabal +++ b/haskoin-node.cabal @@ -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 - diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 --- a/stack.yaml +++ /dev/null @@ -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 diff --git a/tests/Network/Haskoin/Node/Units.hs b/tests/Network/Haskoin/Node/Units.hs --- a/tests/Network/Haskoin/Node/Units.hs +++ b/tests/Network/Haskoin/Node/Units.hs @@ -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"