haskoin-node 0.3.0 → 0.3.1

raw patch · 3 files changed

+48/−37 lines, 3 files

Files

• Network/Haskoin/Node/BlockChain.hs +35/−23
• Network/Haskoin/Node/HeaderTree.hs +12/−13
• haskoin-node.cabal +1/−1

@@ -128,21 +128,27 @@ -- rescans. merkleDownload     :: (MonadLoggerIO m, MonadBaseControl IO m)-    => NodeBlock+    => BlockHash     -> Word32     -> NodeT m        (BlockChainAction, Source (NodeT m) (Either (MerkleBlock, MerkleTxs) Tx))-merkleDownload bh batchSize = do+merkleDownload walletHash batchSize = do     -- Store the best block received from the wallet for information only.     -- This will be displayed in `hw status`-    atomicallyNodeT $ writeTVarS sharedBestBlock bh-    merkleCheckSync+    merkleSyncedActions walletHash+    walletBlockM <- runSqlNodeT $ getBlockByHash walletHash+    walletBlock <- case walletBlockM of+        Just walletBlock -> do+            atomicallyNodeT $ writeTVarS sharedBestBlock walletBlock+            return walletBlock+        Nothing ->+            error "Could not find wallet best block in headers"     rescanTMVar <- asks sharedRescan     -- 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         (fmap Left $ lift $ takeTMVar rescanTMVar)-        (const (Right ()) <$> waitNewBlock (nodeHash bh))+        (const (Right ()) <$> waitNewBlock walletHash)     resM <- case resE of         -- A rescan was triggered         Left valE -> do@@ -154,16 +160,16 @@                 [ "Rescan condition reached:", show newValE ]             case newValE of                 Left ts -> tryMerkleDwnTimestamp ts batchSize-                Right _ -> tryMerkleDwnHeight bh batchSize+                Right _ -> tryMerkleDwnHeight walletBlock batchSize         -- Continue download from a hash-        Right _ -> tryMerkleDwnBlock bh batchSize+        Right _ -> tryMerkleDwnBlock walletBlock batchSize     case resM of         Just res -> return res         _ -> do             $(logWarn) "Invalid merkleDownload result. Retrying ..."             -- Sleep 10 seconds and retry             liftIO $ threadDelay $ 10*1000000-            merkleDownload bh batchSize+            merkleDownload walletHash batchSize   where     waitRescan rescanTMVar valE = do         resE <- atomicallyNodeT $ orElseNodeT@@ -176,21 +182,30 @@         Left ts -> waitFastCatchup ts         Right h -> waitHeight h -merkleCheckSync :: (MonadLoggerIO m, MonadBaseControl IO m)-                => NodeT m ()-merkleCheckSync = do+-- | Perform some actions only when headers have been synced.+merkleSyncedActions+    :: (MonadLoggerIO m, MonadBaseControl IO m)+    => BlockHash -- ^ Wallet best block+    -> NodeT m ()+merkleSyncedActions walletHash =+    asks sharedSyncLock >>= \lock -> liftBaseOp_ (Lock.with lock) $ do     -- Check if we are synced-    (synced, mempool, ourHeight) <- atomicallyNodeT $ do-        synced <- areBlocksSynced-        when synced $ writeTVarS sharedMerklePeer Nothing-        ourHeight <- nodeBlockHeight <$> readTVarS sharedBestHeader+    (synced, mempool, header) <- atomicallyNodeT $ do+        header <- readTVarS sharedBestHeader+        synced <- areBlocksSynced walletHash         mempool <- readTVarS sharedMempool-        return (synced, mempool, ourHeight)+        return (synced, mempool, header)     when synced $ do         $(logInfo) $ pack $ unwords             [ "Merkle blocks are in sync with the"-            , "network at height", show ourHeight+            , "network at height", show walletHash             ]+        -- Prune side chains+        bestBlock <- runSqlNodeT $ pruneChain header+        atomicallyNodeT $ do+            -- Update shared best header after pruning+            writeTVarS sharedBestHeader bestBlock+            writeTVarS sharedMerklePeer Nothing         -- Do a mempool sync on the first merkle sync         unless mempool $ do             atomicallyNodeT $ do@@ -469,8 +484,6 @@         (synced, ourHeight) <- syncedHeight         if synced             then do-                -- Check if merkles are synced-                merkleCheckSync                 $(logInfo) $ formatPid pid peerSessionHost $ unwords                     [ "Block headers are in sync with the"                     , "network at height", show ourHeight@@ -516,12 +529,11 @@                 , "network at height", show ourHeight                 ] -areBlocksSynced :: NodeT STM Bool-areBlocksSynced = do+areBlocksSynced :: BlockHash -> NodeT STM Bool+areBlocksSynced walletHash = do     headersSynced <- areHeadersSynced-    bestBlock     <- readTVarS sharedBestBlock     bestHeader    <- readTVarS sharedBestHeader-    return $ headersSynced && nodeHash bestBlock == nodeHash bestHeader+    return $ headersSynced && walletHash == nodeHash bestHeader  -- Check if the block headers are synced with the network height areHeadersSynced :: NodeT STM Bool

@@ -37,6 +37,7 @@ , connectHeader , connectHeaders , blockLocator+, pruneChain ) where  import           Control.Monad                         (foldM, forM, unless,@@ -616,8 +617,7 @@ 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+        return $ BestChain newNodes     | nodeBlockWork (last newNodes) > nodeBlockWork best = do         (split, old, new) <- splitChains (best, 0) (head newNodes, 0)         return $ ChainReorg split old (new ++ tail newNodes)@@ -629,16 +629,15 @@   where     buildsOnBest = nodePrev (head newNodes) == nodeHash best +-- | Remove all other chains from database and return updated best block node. 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+           -> SqlPersistT m NodeBlock+pruneChain best = if (nodeBlockChain best == 0) then return best else do+    forks <- reverse <$> getPivots best+    delete $ from $ \t -> where_ $ not_ (chainPathQuery t forks)+    update $ \t -> do+        set t [ NodeBlockChain =. val 0 ]+        where_ $ t ^. NodeBlockHeight <=. val (nodeBlockHeight best)+              &&. t ^. NodeBlockChain  !=. val 0+    return best{ nodeBlockChain = 0 }

@@ -1,5 +1,5 @@ name:                  haskoin-node-version:               0.3.0+version:               0.3.1 synopsis:     Implementation of a Bitoin node. description: