1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Network.DHT.Mainline where
import Data.Digest.CRC32C
import Control.Applicative
import Data.Maybe
import Data.Monoid
import Data.Word
import Data.IP
import Data.BEncode as BE
import Data.Bits
import Data.ByteString (ByteString)
import Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Char8 as Char8
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L
import Data.Default
import Data.LargeWord
import Data.Serialize as S
import Data.String
import Data.Typeable
import Network.DatagramServer.Mainline as KRPC
import Network.DatagramServer.Types as RPC
import Text.PrettyPrint as PP hiding ((<>))
import Text.PrettyPrint.HughesPJClass hiding (($$), (<>))
nodeIdSize = finiteBitSize (undefined :: NodeId KMessageOf) `div` 8
instance BEncode (NodeId KMessageOf) where
toBEncode (NodeId w) = toBEncode $ S.encode w
fromBEncode bval = fromBEncode bval >>= S.decode
-- instance BEncode NodeId where TODO
-- TODO: put this somewhere appropriate
instance (Serialize a, Serialize b) => Serialize (LargeKey a b) where
put (LargeKey lo hi) = put hi >> put lo
get = flip LargeKey <$> get <*> get
instance Serialize (NodeId KMessageOf) where
get = NodeId <$> get
{-# INLINE get #-}
put (NodeId bs) = put bs
{-# INLINE put #-}
-- | ASCII encoded.
instance IsString (NodeId KMessageOf) where
fromString str
| length str == nodeIdSize = NodeId (either error id $ S.decode (fromString str :: ByteString))
| length str == 2 * nodeIdSize = NodeId (either error id $ S.decode (fst $ Base16.decode $ fromString str))
| otherwise = error "fromString: invalid NodeId length"
{-# INLINE fromString #-}
-- | Meaningless node id, for testing purposes only.
instance Default (NodeId KMessageOf) where
def = NodeId 0
-- | base16 encoded.
instance Pretty (NodeId KMessageOf) where
pPrint (NodeId nid) = PP.text $ Char8.unpack $ Base16.encode $ S.encode nid
-- | KRPC 'compact list' compatible encoding: contact information for
-- nodes is encoded as a 26-byte string. Also known as "Compact node
-- info" the 20-byte Node ID in network byte order has the compact
-- IP-address/port info concatenated to the end.
instance Serialize a => Serialize (NodeInfo KMessageOf a ()) where
get = (\a b -> NodeInfo a b ()) <$> get <*> get
put NodeInfo {..} = put nodeId >> put nodeAddr
instance Pretty ip => Pretty (NodeInfo KMessageOf ip ()) where
pPrint NodeInfo {..} = pPrint nodeId <> "@(" <> pPrint nodeAddr <> ")"
instance Pretty ip => Pretty [NodeInfo KMessageOf ip ()] where
pPrint = PP.vcat . PP.punctuate "," . map pPrint
-- | Yields all 8 DHT neighborhoods available to you given a particular ip
-- address.
bep42s :: Address a => a -> NodeId KMessageOf -> [NodeId KMessageOf]
bep42s addr (NodeId r) = mapMaybe (bep42 addr) rs
where
rs = map (NodeId . change3bits r) [0..7]
-- change3bits :: ByteString -> Word8 -> ByteString
-- change3bits bs n = BS.snoc (BS.init bs) (BS.last bs .&. 0xF8 .|. n)
change3bits :: (Num b, Bits b) => b -> b -> b
change3bits bs n = (bs .&. complement 7) .|. n
-- | Modifies a purely random 'NodeId' to one that is related to a given
-- routable address in accordance with BEP 42.
bep42 :: Address a => a -> NodeId KMessageOf -> Maybe (NodeId KMessageOf)
bep42 addr (NodeId r)
| Just ip <- fmap S.encode (fromAddr addr :: Maybe IPv4)
<|> fmap S.encode (fromAddr addr :: Maybe IPv6)
= genBucketSample' retr (NodeId $ crc $ applyMask ip) (3,0x07,0)
| otherwise
= Nothing
where
ip4mask = "\x03\x0f\x3f\xff" :: ByteString
ip6mask = "\x01\x03\x07\x0f\x1f\x3f\x7f\xff" :: ByteString
nbhood_select = (fromIntegral r :: Word8) .&. 7
retr n = pure $ BS.drop (nodeIdSize - n) $ S.encode r
crc = flip shiftL (finiteBitSize (NodeId undefined) - 32) . fromIntegral . crc32c . BS.pack
applyMask ip = case BS.zipWith (.&.) msk ip of
(b:bs) -> (b .|. shiftL nbhood_select 5) : bs
bs -> bs
where msk | BS.length ip == 4 = ip4mask
| otherwise = ip6mask
instance Envelope KMessageOf where
type TransactionID KMessageOf = KRPC.TransactionId
-- | Each node has a globally unique identifier known as the \"node
-- ID.\"
--
-- Normally, /this/ node id should be saved between invocations
-- of the client software.
newtype NodeId KMessageOf = NodeId Word160
deriving (Show, Eq, Ord, Typeable, Bits, FiniteBits)
envelopePayload (Q q) = queryArgs q
envelopePayload (R r) = respVals r
envelopePayload (E _) = error "TODO: messagePayload for KError"
envelopeTransaction (Q q) = queryId q
envelopeTransaction (R r) = respId r
envelopeTransaction (E e) = errorId e
envelopeClass (Q _) = Query
envelopeClass (R _) = Response
envelopeClass (E _) = Error
buildReply self addr qry response =
(R (KResponse response (envelopeTransaction qry) (Just $ ReflectedIP addr)))
instance WireFormat BValue KMessageOf where
type SerializableTo BValue = BEncode
type CipherContext BValue KMessageOf = ()
decodeHeaders _ bs = BE.decode bs >>= BE.fromBEncode
decodePayload kmsg = mapM BE.fromBEncode kmsg
encodeHeaders _ kmsg = L.toStrict $ BE.encode kmsg
encodePayload msg = fmap BE.toBEncode msg
|
