haskoin-node 0.17.14 → 0.18.0

raw patch · 6 files changed

+89/−67 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−1
• haskoin-node.cabal +2/−2
• src/Haskoin/Node.hs +8/−6
• src/Haskoin/Node/Manager.hs +39/−30
• src/Haskoin/Node/Peer.hs +12/−24
• test/Haskoin/NodeSpec.hs +23/−4

@@ -4,7 +4,11 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). -## 0.17.4+## 0.18.0+### Added+- Support setting up and connecting to IPv6 peers.++## 0.17.14 ### Fixed - Reduce verbosity on incoming header decode test. - Show appropriate error message upon receiving empty headers.

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 5d100416eb908a4c0c3c591ab5da8a5d02f56be464f1e8fe78672e19289ffdd6+-- hash: 0599a43964ddf1a639dbe9c035528e09c5e2dd566032823d915459e8a314c6af  name:           haskoin-node-version:        0.17.14+version:        0.18.0 synopsis:       P2P library for Bitcoin and Bitcoin Cash description:    Please see the README on GitHub at <https://github.com/haskoin/haskoin-node#readme> category:       Bitcoin, Finance, Network

@@ -16,7 +16,7 @@ import           Control.Monad           (forever) import           Control.Monad.Logger    (MonadLoggerIO) import           Data.Conduit.Network    (appSink, appSource, clientSettings,-                                          runTCPClient)+                                          runTCPClient, ClientSettings) import           Data.String.Conversions (cs) import           Data.Time.Clock         (NominalDiffTime) import           Database.RocksDB        (ColumnFamily, DB)@@ -42,7 +42,7 @@       -- ^ database handler     , nodeConfColumnFamily :: !(Maybe ColumnFamily)       -- ^ database column family-    , nodeConfPeers        :: ![HostPort]+    , nodeConfPeers        :: ![String]       -- ^ static list of peers to connect to     , nodeConfDiscover     :: !Bool       -- ^ activate peer discovery@@ -73,18 +73,20 @@ withConnection na f =     fromSockAddr na >>= \case         Nothing -> throwIO PeerAddressInvalid-        Just (host, port) -> do-            let cset = clientSettings port (cs host)+        Just cset ->             runTCPClient cset $ \ad ->                 f (Conduits (appSource ad) (appSink ad))  fromSockAddr ::-       (MonadUnliftIO m) => SockAddr -> m (Maybe HostPort)+       (MonadUnliftIO m) => SockAddr -> m (Maybe ClientSettings) fromSockAddr sa = go `catch` e   where     go = do         (maybe_host, maybe_port) <- liftIO (getNameInfo flags True True sa)-        return $ (,) <$> maybe_host <*> (readMaybe =<< maybe_port)+        return $+          clientSettings +          <$> (readMaybe =<< maybe_port) +          <*> (cs <$> maybe_host)     flags = [NI_NUMERICHOST, NI_NUMERICSERV]     e :: Monad m => SomeException -> m (Maybe a)     e _ = return Nothing

@@ -10,9 +10,6 @@     ( PeerManagerConfig (..)     , PeerEvent (..)     , OnlinePeer (..)-    , HostPort-    , Host-    , Port     , PeerManager     , withPeerManager     , managerBest@@ -26,8 +23,11 @@     , getOnlinePeer     , buildVersion     , myVersion+    , toSockAddr+    , toHostService     ) where +import           Control.Arrow import           Control.Monad             (forM_, forever, guard, void, when,                                             (<=<)) import           Control.Monad.Except      (ExceptT (..), runExceptT,@@ -41,7 +41,7 @@ import           Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import           Data.Bits                 ((.&.)) import           Data.Function             (on)-import           Data.List                 (find, nub, sort)+import           Data.List                 (find, nub, sort, dropWhileEnd, elemIndex) import           Data.Maybe                (fromMaybe, isJust) import           Data.Set                  (Set) import qualified Data.Set                  as Set@@ -76,10 +76,6 @@                                             withAsync, withRunInIO, writeTVar) import           UnliftIO.Concurrent       (threadDelay) -type HostPort = (Host, Port)-type Host = String-type Port = Int- type MonadManager m = (MonadIO m, MonadReader PeerManager m)  data PeerEvent@@ -90,7 +86,7 @@ data PeerManagerConfig =     PeerManagerConfig         { peerManagerMaxPeers :: !Int-        , peerManagerPeers    :: ![HostPort]+        , peerManagerPeers    :: ![String]         , peerManagerDiscover :: !Bool         , peerManagerNetAddr  :: !NetworkAddress         , peerManagerNetwork  :: !Network@@ -213,15 +209,16 @@  loadStaticPeers :: (MonadUnliftIO m, MonadManager m) => m () loadStaticPeers = do+    net <- asks (peerManagerNetwork . myConfig)     xs <- asks (peerManagerPeers . myConfig)-    mapM_ newPeer =<< concat <$> mapM toSockAddr xs+    mapM_ newPeer . concat =<< mapM (toSockAddr net) xs  loadNetSeeds :: (MonadUnliftIO m, MonadManager m) => m () loadNetSeeds =     asks (peerManagerDiscover . myConfig) >>= \discover ->         when discover $ do             net <- getNetwork-            ss <- concat <$> mapM toSockAddr (networkSeeds net)+            ss <- concat <$> mapM (toSockAddr net) (getSeeds net)             mapM_ newPeer ss  logConnectedPeers :: (MonadManager m, MonadLoggerIO m) => m ()@@ -538,9 +535,6 @@             Just _  -> return ()             Nothing -> modifyTVar b $ Set.insert sa -networkSeeds :: Network -> [HostPort]-networkSeeds net = map (, getDefaultPort net) (getSeeds net)- gotPong :: TVar [OnlinePeer] -> Word64 -> UTCTime -> Peer -> STM () gotPong b nonce now p = void . runMaybeT $ do     o <- MaybeT $ findPeer b p@@ -700,20 +694,36 @@ managerTickle p mgr =     PeerTickle p `send` myMailbox mgr -toSockAddr :: MonadUnliftIO m => HostPort -> m [SockAddr]-toSockAddr (host, port) = go `catch` e+toHostService :: String -> (Maybe String, Maybe String)+toHostService str =+    let host = case m6 of+            Just (x, _) -> Just x+            Nothing -> case takeWhile (/= ':') str of+                [] -> Nothing+                xs -> Just xs+        srv = case m6 of+            Just (_, y) -> s y+            Nothing -> s str+        s xs =+            case dropWhile (/= ':') xs of+                [] -> Nothing+                _ : ys -> Just ys+        m6 = case str of+            (x : xs)+                | x == '[' -> do+                    i <- elemIndex ']' xs+                    return $ second tail $ splitAt i xs+                | x == ':' -> do+                    return (str, "")+            _ -> Nothing+    in (host, srv)++toSockAddr :: MonadUnliftIO m => Network -> String -> m [SockAddr]+toSockAddr net str = +    go `catch` e   where-    go =-        fmap (map addrAddress) . liftIO $-        getAddrInfo-            (Just-                 defaultHints-                 { addrFlags = [AI_ADDRCONFIG]-                 , addrSocketType = Stream-                 , addrFamily = AF_INET-                 })-            (Just host)-            (Just (show port))+    go = fmap (map addrAddress) $ liftIO $ getAddrInfo Nothing host srv+    (host, srv) = toHostService str     e :: Monad m => SomeException -> m [SockAddr]     e _ = return [] @@ -721,12 +731,11 @@ median ls     | null ls =           Nothing-    | length ls `mod` 2 == 0 =+    | even (length ls) =           Just . (/ 2) . sum . take 2 $           drop (length ls `div` 2 - 1) ls'     | otherwise =-          Just . head $-          drop (length ls `div` 2) ls'+          Just (ls' !! (length ls `div` 2))   where     ls' = sort ls 

@@ -4,8 +4,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE RecordWildCards       #-}-{-# LANGUAGE TemplateHaskell       #-}-{-# LANGUAGE TupleSections         #-} {-# LANGUAGE TypeFamilies          #-} module Haskoin.Node.Peer     ( PeerConfig(..)@@ -150,28 +148,27 @@      -> TVar Bool      -> Inbox PeerMessage      -> m ()-peer cfg busy inbox = do+peer cfg@PeerConfig{..} busy inbox = do     p <- wrapPeer cfg busy (inboxToMailbox inbox)-    withRunInIO $ connect . (. peer_session p)+    withRunInIO $ \restore -> do+        peerConfConnect (peer_session p)   where-    connect = peerConfConnect cfg     go = forever $ receive inbox >>= dispatchMessage cfg-    net = peerConfNetwork cfg-    peer_session p ad =+    peer_session p ad = do         let ins = transPipe liftIO (inboundConduit ad)             ons = transPipe liftIO (outboundConduit ad)             src = runConduit $                 ins-                .| inPeerConduit net (peerConfText cfg)+                .| inPeerConduit peerConfNetwork peerConfText                 .| mapM_C (send_msg p)-            snk = outPeerConduit net .| ons-         in withAsync src $ \as -> do-                link as-                runConduit (go .| snk)-    send_msg p msg = publish (p, msg) (peerConfPub cfg)+            snk = outPeerConduit peerConfNetwork .| ons+        withAsync src $ \as -> do+            link as+            runConduit (go .| snk)+    send_msg p msg = publish (p, msg) peerConfPub  -- | Internal function to dispatch peer messages.-dispatchMessage :: MonadLoggerIO m+dispatchMessage :: MonadIO m                 => PeerConfig                 -> PeerMessage                 -> ConduitT i Message m ()@@ -179,7 +176,7 @@ dispatchMessage _ (KillPeer e)      = throwIO e  -- | Internal conduit to parse messages coming from peer.-inPeerConduit :: MonadLoggerIO m+inPeerConduit :: MonadIO m               => Network               -> Text               -> ConduitT ByteString Message m ()@@ -187,25 +184,16 @@     forever $ do         x <- takeCE 24 .| foldC         when (B.null x) $ do-            $(logErrorS) (peerLog a) $ "Peer sent empty header"             throwIO EmptyHeader         case decode x of             Left e -> do-                $(logErrorS) (peerLog a) $-                    "Could not decode message header: \"" <>-                    encodeHex x <> "\""                 throwIO DecodeHeaderError             Right (MessageHeader _ cmd len _) -> do                 when (len > 32 * 2 ^ (20 :: Int)) $ do-                    $(logErrorS) (peerLog a) "Payload too large"                     throwIO $ PayloadTooLarge len                 y <- takeCE (fromIntegral len) .| foldC                 case runGet (getMessage net) $ x `B.append` y of                     Left e -> do-                        $(logErrorS) (peerLog a) $-                            "Cannot decode payload (" <>-                            cs (commandToString cmd) <>-                            "): " <> cs (show e)                         throwIO (CannotDecodePayload cmd)                     Right msg -> yield msg 

@@ -34,16 +34,17 @@                                          getMessage, headerHash, nodeNetwork,                                          putMessage, sockToHostAddress, txHash) import           Haskoin.Node-import           Network.Socket         (SockAddr (..))+import           Network.Socket         (SockAddr (..), AddrInfo (addrAddress)) import           NQE                    (Inbox, Mailbox, inboxToMailbox,                                          newInbox, receive, receiveMatch, send,                                          withPublisher, withSubscription) import           System.Random          (randomIO)-import           Test.Hspec             (Spec, describe, it, shouldBe,-                                         shouldSatisfy)+import           Test.Hspec+import           Test.Hspec.QuickCheck import           UnliftIO               (MonadIO, MonadUnliftIO, liftIO,                                          throwString, withAsync,                                          withSystemTempDirectory)+import Haskoin.Node (toHostService)  data TestNode = TestNode     { testMgr    :: PeerManager@@ -107,6 +108,24 @@ spec :: Spec spec = do     let net = bchRegTest+    describe "reads address/port combinations" $ do+        prop "reads arbitrary addresses" $ \(e, w1, w2, w3, w4, b) -> do+            let p = toEnum (e `mod` 65536)+                a = if b +                    then SockAddrInet p w1+                    else SockAddrInet6 p 0 (w1, w2, w3, w4) 0+            s <- head <$> toSockAddr net (show a)+            s `shouldBe` a+        it "reads some specific addresses" $ do+            toHostService "localhost" `shouldBe` (Just "localhost", Nothing)+            toHostService "::1" `shouldBe` (Just "::1",  Nothing)+            toHostService "localhost:8080" `shouldBe` (Just "localhost", Just "8080")+            toHostService "example.com" `shouldBe` (Just "example.com", Nothing)+            toHostService "api.example.com:443" `shouldBe` (Just "api.example.com", Just "443")+            toHostService "api.example.com:http" `shouldBe` (Just "api.example.com", Just "http")+            toHostService "[::1]" `shouldBe` (Just "::1", Nothing)+            toHostService "[::1]:8080" `shouldBe` (Just "::1", Just "8080")+            toHostService "[2002::dead:beef]:ssh" `shouldBe` (Just "2002::dead:beef", Just "ssh")     describe "peer manager on test network" $ do         it "connects to a peer" $             withTestNode net "connect-one-peer" $ \TestNode {..} -> do@@ -195,7 +214,7 @@                   { nodeConfMaxPeers = 20                   , nodeConfDB = db                   , nodeConfColumnFamily = Just (head (R.columnFamilies db))-                  , nodeConfPeers = [("127.0.0.1", 17486)]+                  , nodeConfPeers = ["[::1]:17486"]                   , nodeConfDiscover = False                   , nodeConfNetAddr = na                   , nodeConfNet = net