summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Mainline.hs46
-rw-r--r--src/Network/Address.hs37
2 files changed, 45 insertions, 38 deletions
diff --git a/Mainline.hs b/Mainline.hs
index 6aa1c517..77c0d5f1 100644
--- a/Mainline.hs
+++ b/Mainline.hs
@@ -29,7 +29,7 @@ import qualified Data.ByteArray as BA
29import qualified Data.ByteString as B 29import qualified Data.ByteString as B
30 ;import Data.ByteString (ByteString) 30 ;import Data.ByteString (ByteString)
31import qualified Data.ByteString.Base16 as Base16 31import qualified Data.ByteString.Base16 as Base16
32import qualified Data.ByteString.Char8 as Char8 32import qualified Data.ByteString.Char8 as C8
33import Data.ByteString.Lazy (toStrict) 33import Data.ByteString.Lazy (toStrict)
34import qualified Data.ByteString.Lazy.Char8 as L8 34import qualified Data.ByteString.Lazy.Char8 as L8
35import Data.Char 35import Data.Char
@@ -55,7 +55,8 @@ import Debug.Trace
55import Kademlia 55import Kademlia
56import Network.Address (Address, fromAddr, fromSockAddr, 56import Network.Address (Address, fromAddr, fromSockAddr,
57 setPort, sockAddrPort, testIdBit, 57 setPort, sockAddrPort, testIdBit,
58 toSockAddr, genBucketSample') 58 toSockAddr, genBucketSample', WantIP(..),
59 un4map,either4or6,ipFamily)
59import Network.BitTorrent.DHT.ContactInfo as Peers 60import Network.BitTorrent.DHT.ContactInfo as Peers
60import Network.BitTorrent.DHT.Search (Search (..)) 61import Network.BitTorrent.DHT.Search (Search (..))
61import Network.BitTorrent.DHT.Token as Token 62import Network.BitTorrent.DHT.Token as Token
@@ -92,7 +93,7 @@ instance BEncode NodeId where
92 toBEncode (NodeId bs) = toBEncode bs 93 toBEncode (NodeId bs) = toBEncode bs
93 94
94instance Show NodeId where 95instance Show NodeId where
95 show (NodeId bs) = Char8.unpack $ Base16.encode bs 96 show (NodeId bs) = C8.unpack $ Base16.encode bs
96 97
97instance S.Serialize NodeId where 98instance S.Serialize NodeId where
98 get = NodeId <$> S.getBytes 20 99 get = NodeId <$> S.getBytes 20
@@ -103,7 +104,7 @@ instance FiniteBits NodeId where
103 104
104instance Read NodeId where 105instance Read NodeId where
105 readsPrec _ str 106 readsPrec _ str
106 | (bs, xs) <- Base16.decode $ Char8.pack str 107 | (bs, xs) <- Base16.decode $ C8.pack str
107 , B.length bs == 20 108 , B.length bs == 20
108 = [ (NodeId bs, drop 40 str) ] 109 = [ (NodeId bs, drop 40 str) ]
109 | otherwise = [] 110 | otherwise = []
@@ -143,7 +144,7 @@ instance FromJSON NodeInfo where
143 portnum <- v JSON..: "port" 144 portnum <- v JSON..: "port"
144 ip <- maybe empty (return . IPv6) (ip6str >>= readMaybe) 145 ip <- maybe empty (return . IPv6) (ip6str >>= readMaybe)
145 <|> maybe empty (return . IPv4) (ip4str >>= readMaybe) 146 <|> maybe empty (return . IPv4) (ip4str >>= readMaybe)
146 let (bs,_) = Base16.decode (Char8.pack nidstr) 147 let (bs,_) = Base16.decode (C8.pack nidstr)
147 guard (B.length bs == 20) 148 guard (B.length bs == 20)
148 return $ NodeInfo (NodeId bs) ip (fromIntegral (portnum :: Word16)) 149 return $ NodeInfo (NodeId bs) ip (fromIntegral (portnum :: Word16))
149 150
@@ -159,7 +160,7 @@ instance Read NodeInfo where
159 nodeidAt = do hexhash <- sequence $ replicate n (RP.satisfy hexdigit) 160 nodeidAt = do hexhash <- sequence $ replicate n (RP.satisfy hexdigit)
160 RP.char '@' RP.+++ RP.satisfy isSpace 161 RP.char '@' RP.+++ RP.satisfy isSpace
161 addrstr <- parseAddr 162 addrstr <- parseAddr
162 nid <- case Base16.decode $ Char8.pack hexhash of 163 nid <- case Base16.decode $ C8.pack hexhash of
163 (bs,_) | B.length bs==20 -> return (NodeId bs) 164 (bs,_) | B.length bs==20 -> return (NodeId bs)
164 _ -> fail "Bad node id." 165 _ -> fail "Bad node id."
165 return (nid,addrstr) 166 return (nid,addrstr)
@@ -360,12 +361,6 @@ encodeMessage (R origin tid v ip)
360 Right (BDict vals) -> encodeResponse tid (BDict $ genericArgs origin False `BE.union` vals) ip 361 Right (BDict vals) -> encodeResponse tid (BDict $ genericArgs origin False `BE.union` vals) ip
361 Left err -> encodeError tid err 362 Left err -> encodeError tid err
362 363
363either4or6 :: SockAddr -> Either SockAddr SockAddr
364either4or6 a4@(SockAddrInet port addr) = Left a4
365either4or6 a6@(SockAddrInet6 port _ addr _)
366 | Just ip4 <- (fromSockAddr a6 >>= un4map) = Left (setPort port $ toSockAddr ip4)
367 | otherwise = Right a6
368
369 364
370encodeAddr :: SockAddr -> ByteString 365encodeAddr :: SockAddr -> ByteString
371encodeAddr = either encode4 encode6 . either4or6 366encodeAddr = either encode4 encode6 . either4or6
@@ -733,9 +728,6 @@ instance BEncode Ping where
733 toBEncode Ping = toDict endDict 728 toBEncode Ping = toDict endDict
734 fromBEncode _ = pure Ping 729 fromBEncode _ = pure Ping
735 730
736data WantIP = Want_IP4 | Want_IP6 | Want_Both
737 deriving (Eq, Enum, Ord, Show)
738
739wantList :: WantIP -> [ByteString] 731wantList :: WantIP -> [ByteString]
740wantList Want_IP4 = ["ip4"] 732wantList Want_IP4 = ["ip4"]
741wantList Want_IP6 = ["ip6"] 733wantList Want_IP6 = ["ip6"]
@@ -791,31 +783,9 @@ binary get k = field (req k) >>= either (fail . format) return .
791pingH :: NodeInfo -> Ping -> IO Pong 783pingH :: NodeInfo -> Ping -> IO Pong
792pingH _ Ping = return Pong 784pingH _ Ping = return Pong
793 785
794-- | True if the argument is an IPv4-mapped address with prefix ::FFFF:0:0/96
795-- as defined in RFC 4291.
796is4mapped :: IPv6 -> Bool
797is4mapped ip
798 | [0,0,0,0,0,0xffff,_,_] <- fromIPv6 ip
799 = True
800 | otherwise = False
801
802un4map :: IPv6 -> Maybe IPv4
803un4map ip
804 | [0,0,0,0,0,0xffff,x,y] <- fromIPv6 ip
805 = Just $ toIPv4
806 $ map (.&. 0xFF)
807 [x `shiftR` 8, x, y `shiftR` 8, y ]
808 | otherwise = Nothing
809
810prefer4or6 :: NodeInfo -> Maybe WantIP -> WantIP 786prefer4or6 :: NodeInfo -> Maybe WantIP -> WantIP
811prefer4or6 addr iptyp = fromMaybe (ipFamily $ nodeIP addr) iptyp 787prefer4or6 addr iptyp = fromMaybe (ipFamily $ nodeIP addr) iptyp
812 788
813ipFamily :: IP -> WantIP
814ipFamily ip = case ip of
815 IPv4 _ -> Want_IP4
816 IPv6 a | is4mapped a -> Want_IP4
817 | otherwise -> Want_IP6
818
819findNodeH :: Routing -> NodeInfo -> FindNode -> IO NodeFound 789findNodeH :: Routing -> NodeInfo -> FindNode -> IO NodeFound
820findNodeH routing addr (FindNode node iptyp) = do 790findNodeH routing addr (FindNode node iptyp) = do
821 let preferred = prefer4or6 addr iptyp 791 let preferred = prefer4or6 addr iptyp
@@ -1035,7 +1005,7 @@ mainlineSend meth unwrap msg client nid addr = do
1035 { methodTimeout = 5 1005 { methodTimeout = 5
1036 , method = meth 1006 , method = meth
1037 , wrapQuery = encodeQueryPayload meth (isReadonlyClient client) 1007 , wrapQuery = encodeQueryPayload meth (isReadonlyClient client)
1038 , unwrapResponse = (>>= either (Left . Error GenericError . Char8.pack) 1008 , unwrapResponse = (>>= either (Left . Error GenericError . C8.pack)
1039 (Right . unwrap) 1009 (Right . unwrap)
1040 . BE.fromBEncode) 1010 . BE.fromBEncode)
1041 . rspPayload 1011 . rspPayload
diff --git a/src/Network/Address.hs b/src/Network/Address.hs
index 8715a82d..cc06ac0d 100644
--- a/src/Network/Address.hs
+++ b/src/Network/Address.hs
@@ -35,6 +35,11 @@ module Network.Address
35 , IPv4 35 , IPv4
36 , IPv6 36 , IPv6
37 , IP (..) 37 , IP (..)
38 , un4map
39 , WantIP (..)
40 , ipFamily
41 , is4mapped
42 , either4or6
38 43
39 -- * PeerId 44 -- * PeerId
40 -- $peer-id 45 -- $peer-id
@@ -1180,3 +1185,35 @@ getBindAddress listenPortString enabled6 = do
1180 else SockAddrInet (parsePort listenPortString) iNADDR_ANY 1185 else SockAddrInet (parsePort listenPortString) iNADDR_ANY
1181 where parsePort s = fromMaybe 0 $ readMaybe s 1186 where parsePort s = fromMaybe 0 $ readMaybe s
1182 return listenAddr 1187 return listenAddr
1188
1189-- | True if the argument is an IPv4-mapped address with prefix ::FFFF:0:0/96
1190-- as defined in RFC 4291.
1191is4mapped :: IPv6 -> Bool
1192is4mapped ip
1193 | [0,0,0,0,0,0xffff,_,_] <- fromIPv6 ip
1194 = True
1195 | otherwise = False
1196
1197un4map :: IPv6 -> Maybe IPv4
1198un4map ip
1199 | [0,0,0,0,0,0xffff,x,y] <- fromIPv6 ip
1200 = Just $ toIPv4
1201 $ L.map (.&. 0xFF)
1202 [x `shiftR` 8, x, y `shiftR` 8, y ]
1203 | otherwise = Nothing
1204
1205ipFamily :: IP -> WantIP
1206ipFamily ip = case ip of
1207 IPv4 _ -> Want_IP4
1208 IPv6 a | is4mapped a -> Want_IP4
1209 | otherwise -> Want_IP6
1210
1211either4or6 :: SockAddr -> Either SockAddr SockAddr
1212either4or6 a4@(SockAddrInet port addr) = Left a4
1213either4or6 a6@(SockAddrInet6 port _ addr _)
1214 | Just ip4 <- (fromSockAddr a6 >>= un4map) = Left (setPort port $ toSockAddr ip4)
1215 | otherwise = Right a6
1216
1217data WantIP = Want_IP4 | Want_IP6 | Want_Both
1218 deriving (Eq, Enum, Ord, Show)
1219