diff options
author | joe <joe@jerkface.net> | 2017-06-08 03:07:13 -0400 |
---|---|---|
committer | joe <joe@jerkface.net> | 2017-06-08 03:07:13 -0400 |
commit | 8c33deac14ca92ef67afc7fbcd3f67bc19317f88 (patch) | |
tree | e7636f38ae91ff0ef7c84091ccc65048cc45fea5 /src/Network/DHT | |
parent | d6fac9a8df0ce872ede54d6a71ca6d6c750eadc9 (diff) |
WIP: Adapting DHT to Tox network (part 6).
Diffstat (limited to 'src/Network/DHT')
-rw-r--r-- | src/Network/DHT/Mainline.hs | 94 |
1 files changed, 74 insertions, 20 deletions
diff --git a/src/Network/DHT/Mainline.hs b/src/Network/DHT/Mainline.hs index d7aed430..2b7db3c7 100644 --- a/src/Network/DHT/Mainline.hs +++ b/src/Network/DHT/Mainline.hs | |||
@@ -1,15 +1,23 @@ | |||
1 | {-# LANGUAGE LambdaCase #-} | 1 | {-# LANGUAGE LambdaCase #-} |
2 | {-# LANGUAGE MultiParamTypeClasses #-} | 2 | {-# LANGUAGE MultiParamTypeClasses #-} |
3 | {-# LANGUAGE FlexibleInstances #-} | ||
3 | {-# LANGUAGE DeriveDataTypeable #-} | 4 | {-# LANGUAGE DeriveDataTypeable #-} |
4 | {-# LANGUAGE TypeFamilies #-} | 5 | {-# LANGUAGE TypeFamilies #-} |
5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} |
6 | module Network.DHT.Mainline where | 7 | module Network.DHT.Mainline where |
7 | 8 | ||
9 | import Data.Digest.CRC32C | ||
10 | import Control.Applicative | ||
11 | import Data.Maybe | ||
12 | import Data.Monoid | ||
13 | import Data.Word | ||
14 | import Data.IP | ||
8 | import Data.BEncode as BE | 15 | import Data.BEncode as BE |
9 | import Data.Bits | 16 | import Data.Bits |
10 | import Data.ByteString (ByteString) | 17 | import Data.ByteString (ByteString) |
11 | import Data.ByteString.Base16 as Base16 | 18 | import Data.ByteString.Base16 as Base16 |
12 | import qualified Data.ByteString.Char8 as Char8 | 19 | import qualified Data.ByteString.Char8 as Char8 |
20 | import qualified Data.ByteString as BS | ||
13 | import qualified Data.ByteString.Lazy as L | 21 | import qualified Data.ByteString.Lazy as L |
14 | import Data.Default | 22 | import Data.Default |
15 | import Data.LargeWord | 23 | import Data.LargeWord |
@@ -17,28 +25,16 @@ import Data.Serialize as S | |||
17 | import Data.String | 25 | import Data.String |
18 | import Data.Typeable | 26 | import Data.Typeable |
19 | import Network.KRPC.Message as KRPC | 27 | import Network.KRPC.Message as KRPC |
20 | import qualified Network.RPC as RPC (NodeId) | 28 | import Network.RPC as RPC |
21 | ;import Network.RPC as RPC hiding (NodeId) | ||
22 | import Text.PrettyPrint as PP hiding ((<>)) | 29 | import Text.PrettyPrint as PP hiding ((<>)) |
23 | import Text.PrettyPrint.HughesPJClass hiding (($$), (<>)) | 30 | import Text.PrettyPrint.HughesPJClass hiding (($$), (<>)) |
24 | 31 | ||
25 | -- | Each node has a globally unique identifier known as the \"node | 32 | nodeIdSize = finiteBitSize (undefined :: NodeId KMessageOf) `div` 8 |
26 | -- ID.\" | ||
27 | -- | ||
28 | -- Normally, /this/ node id should be saved between invocations | ||
29 | -- of the client software. | ||
30 | newtype NodeId = NodeId Word160 | ||
31 | deriving (Show, Eq, Ord, Typeable, Bits, FiniteBits) | ||
32 | 33 | ||
33 | instance BEncode NodeId where | 34 | instance BEncode (NodeId KMessageOf) where |
34 | toBEncode (NodeId w) = toBEncode $ S.encode w | 35 | toBEncode (NodeId w) = toBEncode $ S.encode w |
35 | fromBEncode bval = fromBEncode bval >>= S.decode | 36 | fromBEncode bval = fromBEncode bval >>= S.decode |
36 | 37 | ||
37 | -- | NodeId size in bytes. | ||
38 | nodeIdSize :: Int | ||
39 | nodeIdSize = 20 | ||
40 | |||
41 | |||
42 | -- instance BEncode NodeId where TODO | 38 | -- instance BEncode NodeId where TODO |
43 | 39 | ||
44 | -- TODO: put this somewhere appropriate | 40 | -- TODO: put this somewhere appropriate |
@@ -46,14 +42,14 @@ instance (Serialize a, Serialize b) => Serialize (LargeKey a b) where | |||
46 | put (LargeKey lo hi) = put hi >> put lo | 42 | put (LargeKey lo hi) = put hi >> put lo |
47 | get = flip LargeKey <$> get <*> get | 43 | get = flip LargeKey <$> get <*> get |
48 | 44 | ||
49 | instance Serialize NodeId where | 45 | instance Serialize (NodeId KMessageOf) where |
50 | get = NodeId <$> get | 46 | get = NodeId <$> get |
51 | {-# INLINE get #-} | 47 | {-# INLINE get #-} |
52 | put (NodeId bs) = put bs | 48 | put (NodeId bs) = put bs |
53 | {-# INLINE put #-} | 49 | {-# INLINE put #-} |
54 | 50 | ||
55 | -- | ASCII encoded. | 51 | -- | ASCII encoded. |
56 | instance IsString NodeId where | 52 | instance IsString (NodeId KMessageOf) where |
57 | fromString str | 53 | fromString str |
58 | | length str == nodeIdSize = NodeId (either error id $ S.decode (fromString str :: ByteString)) | 54 | | length str == nodeIdSize = NodeId (either error id $ S.decode (fromString str :: ByteString)) |
59 | | length str == 2 * nodeIdSize = NodeId (either error id $ S.decode (fst $ Base16.decode $ fromString str)) | 55 | | length str == 2 * nodeIdSize = NodeId (either error id $ S.decode (fst $ Base16.decode $ fromString str)) |
@@ -61,16 +57,74 @@ instance IsString NodeId where | |||
61 | {-# INLINE fromString #-} | 57 | {-# INLINE fromString #-} |
62 | 58 | ||
63 | -- | Meaningless node id, for testing purposes only. | 59 | -- | Meaningless node id, for testing purposes only. |
64 | instance Default NodeId where | 60 | instance Default (NodeId KMessageOf) where |
65 | def = NodeId 0 | 61 | def = NodeId 0 |
66 | 62 | ||
67 | -- | base16 encoded. | 63 | -- | base16 encoded. |
68 | instance Pretty NodeId where | 64 | instance Pretty (NodeId KMessageOf) where |
69 | pPrint (NodeId nid) = PP.text $ Char8.unpack $ Base16.encode $ S.encode nid | 65 | pPrint (NodeId nid) = PP.text $ Char8.unpack $ Base16.encode $ S.encode nid |
70 | 66 | ||
67 | -- | KRPC 'compact list' compatible encoding: contact information for | ||
68 | -- nodes is encoded as a 26-byte string. Also known as "Compact node | ||
69 | -- info" the 20-byte Node ID in network byte order has the compact | ||
70 | -- IP-address/port info concatenated to the end. | ||
71 | instance Serialize a => Serialize (NodeInfo KMessageOf a ()) where | ||
72 | get = (\a b -> NodeInfo a b ()) <$> get <*> get | ||
73 | put NodeInfo {..} = put nodeId >> put nodeAddr | ||
74 | |||
75 | instance Pretty ip => Pretty (NodeInfo KMessageOf ip ()) where | ||
76 | pPrint NodeInfo {..} = pPrint nodeId <> "@(" <> pPrint nodeAddr <> ")" | ||
77 | |||
78 | instance Pretty ip => Pretty [NodeInfo KMessageOf ip ()] where | ||
79 | pPrint = PP.vcat . PP.punctuate "," . map pPrint | ||
80 | |||
81 | |||
82 | -- | Yields all 8 DHT neighborhoods available to you given a particular ip | ||
83 | -- address. | ||
84 | bep42s :: Address a => a -> NodeId KMessageOf -> [NodeId KMessageOf] | ||
85 | bep42s addr (NodeId r) = mapMaybe (bep42 addr) rs | ||
86 | where | ||
87 | rs = map (NodeId . change3bits r) [0..7] | ||
88 | |||
89 | -- change3bits :: ByteString -> Word8 -> ByteString | ||
90 | -- change3bits bs n = BS.snoc (BS.init bs) (BS.last bs .&. 0xF8 .|. n) | ||
91 | |||
92 | change3bits :: (Num b, Bits b) => b -> b -> b | ||
93 | change3bits bs n = (bs .&. complement 7) .|. n | ||
94 | |||
95 | -- | Modifies a purely random 'NodeId' to one that is related to a given | ||
96 | -- routable address in accordance with BEP 42. | ||
97 | bep42 :: Address a => a -> NodeId KMessageOf -> Maybe (NodeId KMessageOf) | ||
98 | bep42 addr (NodeId r) | ||
99 | | Just ip <- fmap S.encode (fromAddr addr :: Maybe IPv4) | ||
100 | <|> fmap S.encode (fromAddr addr :: Maybe IPv6) | ||
101 | = genBucketSample' retr (NodeId $ crc $ applyMask ip) (3,0x07,0) | ||
102 | | otherwise | ||
103 | = Nothing | ||
104 | where | ||
105 | ip4mask = "\x03\x0f\x3f\xff" :: ByteString | ||
106 | ip6mask = "\x01\x03\x07\x0f\x1f\x3f\x7f\xff" :: ByteString | ||
107 | nbhood_select = (fromIntegral r :: Word8) .&. 7 | ||
108 | retr n = pure $ BS.drop (nodeIdSize - n) $ S.encode r | ||
109 | crc = flip shiftL (finiteBitSize (NodeId undefined) - 32) . fromIntegral . crc32c . BS.pack | ||
110 | applyMask ip = case BS.zipWith (.&.) msk ip of | ||
111 | (b:bs) -> (b .|. shiftL nbhood_select 5) : bs | ||
112 | bs -> bs | ||
113 | where msk | BS.length ip == 4 = ip4mask | ||
114 | | otherwise = ip6mask | ||
115 | |||
116 | |||
117 | |||
71 | instance Envelope KMessageOf where | 118 | instance Envelope KMessageOf where |
72 | type TransactionID KMessageOf = KRPC.TransactionId | 119 | type TransactionID KMessageOf = KRPC.TransactionId |
73 | type NodeId KMessageOf = Network.DHT.Mainline.NodeId | 120 | |
121 | -- | Each node has a globally unique identifier known as the \"node | ||
122 | -- ID.\" | ||
123 | -- | ||
124 | -- Normally, /this/ node id should be saved between invocations | ||
125 | -- of the client software. | ||
126 | newtype NodeId KMessageOf = NodeId Word160 | ||
127 | deriving (Show, Eq, Ord, Typeable, Bits, FiniteBits) | ||
74 | 128 | ||
75 | envelopePayload (Q q) = queryArgs q | 129 | envelopePayload (Q q) = queryArgs q |
76 | envelopePayload (R r) = respVals r | 130 | envelopePayload (R r) = respVals r |