diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/haskoin-node.cabal b/haskoin-node.cabal --- a/haskoin-node.cabal +++ b/haskoin-node.cabal @@ -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 category: Bitcoin, Finance, Network diff --git a/src/Haskoin/Node.hs b/src/Haskoin/Node.hs --- a/src/Haskoin/Node.hs +++ b/src/Haskoin/Node.hs @@ -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 diff --git a/src/Haskoin/Node/Manager.hs b/src/Haskoin/Node/Manager.hs --- a/src/Haskoin/Node/Manager.hs +++ b/src/Haskoin/Node/Manager.hs @@ -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 diff --git a/src/Haskoin/Node/Peer.hs b/src/Haskoin/Node/Peer.hs --- a/src/Haskoin/Node/Peer.hs +++ b/src/Haskoin/Node/Peer.hs @@ -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 diff --git a/test/Haskoin/NodeSpec.hs b/test/Haskoin/NodeSpec.hs --- a/test/Haskoin/NodeSpec.hs +++ b/test/Haskoin/NodeSpec.hs @@ -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