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
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
module DHTTransport
( parseDHTAddr
, encodeDHTAddr
, forwardDHTRequests
, module ToxAddress
, DHTMessage(..)
, Ping(..)
, Pong(..)
, GetNodes(..)
, SendNodes(..)
, CookieRequest
, Cookie
, DHTRequest
, mapMessage
) where
import ToxAddress
import ToxCrypto
import Network.QueryResponse
import Control.Arrow
import qualified Data.ByteString as B
;import Data.ByteString (ByteString)
import Data.Serialize as S (Get, Serialize, get, put, runGet)
import Data.Word
import Network.Socket
type DHTTransport = Transport String NodeInfo (DHTMessage Encrypted8)
type HandleHi a = Maybe (Either String (DHTMessage Encrypted8, NodeInfo)) -> IO a
data DHTMessage (f :: * -> *)
= DHTPing (Assym (f Ping))
| DHTPong (Assym (f Pong))
| DHTGetNodes (Assym (f GetNodes))
| DHTSendNodes (Assym (f SendNodes))
| DHTCookieRequest (Assym (f CookieRequest))
| DHTCookie Nonce24 (f Cookie)
| DHTDHTRequest PublicKey (Assym (f DHTRequest))
mapMessage :: forall f b. (forall a. Nonce24 -> f a -> b) -> DHTMessage f -> b
mapMessage f msg = f _todo _todo
instance Sized GetNodes where
size = ConstSize 32 -- TODO This right?
instance Sized SendNodes where
size = VarSize $ \(SendNodes ns) -> _nodeFormatSize * length ns
instance Sized Ping where size = ConstSize 1
instance Sized Pong where size = ConstSize 1
parseDHTAddr :: (ByteString, SockAddr) -> Either (DHTMessage Encrypted8,NodeInfo) (ByteString,SockAddr)
parseDHTAddr (msg,saddr)
| Just (typ,bs) <- B.uncons msg
, let right = Right (msg,saddr)
left = either (const right) Left
= case typ of
0x00 -> left $ direct bs saddr DHTPing
0x01 -> left $ direct bs saddr DHTPong
0x02 -> left $ direct bs saddr DHTGetNodes
0x04 -> left $ direct bs saddr DHTSendNodes
0x18 -> left $ direct bs saddr DHTCookieRequest
0x19 -> left $ fanGet bs getCookie (uncurry DHTCookie) (const $ noReplyAddr saddr)
0x20 -> left $ fanGet bs getDHTReqest (uncurry DHTDHTRequest) (asymNodeInfo saddr . snd)
_ -> right
encodeDHTAddr :: (DHTMessage Encrypted8,NodeInfo) -> (ByteString, SockAddr)
encodeDHTAddr = _todo
getCookie :: Get (Nonce24, Encrypted8 Cookie)
getCookie = get
getDHTReqest :: Get (PublicKey, Assym (Encrypted8 DHTRequest))
getDHTReqest = _todo
getDHT :: Sized a => Get (Assym (Encrypted8 a))
getDHT = _todo
-- Throws an error if called with a non-internet socket.
direct :: Sized a => ByteString
-> SockAddr
-> (Assym (Encrypted8 a)
-> DHTMessage Encrypted8)
-> Either String (DHTMessage Encrypted8, NodeInfo)
direct bs saddr f = fanGet bs getDHT f (asymNodeInfo saddr)
-- Throws an error if called with a non-internet socket.
asymNodeInfo saddr asym = either (error . mappend "asymNodeInfo: ") id $ nodeInfo (NodeId $ senderKey asym) saddr
fanGet :: ByteString -> Get x -> (x -> a) -> (x -> b) -> Either String (a,b)
fanGet bs getIt f nid = fmap (f &&& nid) $ runGet getIt bs
-- Throws an error if called with a non-internet socket.
noReplyAddr saddr = either (error . mappend "noReplyAddr: ") id $ nodeInfo zeroID saddr
-- ## DHT Request packets
--
-- | Length | Contents |
-- |:-------|:--------------------------|
-- | `1` | `uint8_t` (0x20) |
-- | `32` | receiver's DHT public key |
-- ... ...
data DHTRequestPacket = DHTRequestPacket
{ requestTarget :: PublicKey
, request :: Assym (Encrypted DHTRequest)
}
instance Serialize DHTRequestPacket where
get = _todo
put = _todo
data DHTRequest
= NATPing Nonce8
| NATPong Nonce8
| DHTPK DHTPublicKey
-- | Length | Contents |
-- |:------------|:------------------------------------|
-- | `1` | `uint8_t` (0x9c) |
-- | `8` | `uint64_t` `no_replay` |
-- | `32` | Our DHT public key |
-- | `[39, 204]` | Maximum of 4 nodes in packed format |
data DHTPublicKey = DHTPublicKey
{ dhtpkNonce :: Nonce8
, dhtpk :: PublicKey
, dhtpkNodes :: SendNodes
}
newtype GetNodes = GetNodes NodeId
deriving (Eq,Ord,Show,Read,S.Serialize)
newtype SendNodes = SendNodes [NodeInfo]
deriving (Eq,Ord,Show,Read)
instance S.Serialize SendNodes where
get = do
cnt <- S.get :: S.Get Word8
ns <- sequence $ replicate (fromIntegral cnt) S.get
return $ SendNodes ns
put (SendNodes ns) = do
let ns' = take 4 ns
S.put (fromIntegral (length ns') :: Word8)
mapM_ S.put ns'
data Ping = Ping deriving Show
data Pong = Pong deriving Show
instance S.Serialize Ping where
get = do w8 <- S.get
if (w8 :: Word8) /= 0
then fail "Malformed ping."
else return Ping
put Ping = S.put (0 :: Word8)
instance S.Serialize Pong where
get = do w8 <- S.get
if (w8 :: Word8) /= 1
then fail "Malformed pong."
else return Pong
put Pong = S.put (1 :: Word8)
newtype CookieRequest = CookieRequest PublicKey
newtype CookieResponse = CookieResponse Cookie
data Cookie = Cookie Nonce24 (Encrypted CookieData)
instance Sized Cookie where size = ConstSize 112 -- 24 byte nonce + 88 byte cookie data
data CookieData = CookieData -- 16 (mac)
{ cookieTime :: Word64 -- 8
, longTermKey :: PublicKey -- 32
, dhtKey :: PublicKey -- + 32
} -- = 88 bytes when encrypted.
instance Sized CookieRequest where
size = ConstSize 64 -- 32 byte key + 32 byte padding
forwardDHTRequests :: TransportCrypto -> (PublicKey -> IO (Maybe NodeInfo)) -> DHTTransport -> DHTTransport
forwardDHTRequests crypto closeLookup dht = dht { awaitMessage = await' }
where
await' :: HandleHi a -> IO a
await' pass = awaitMessage dht $ \case
Just (Right (m@(DHTDHTRequest target payload),src)) | target /= transportPublic crypto
-> do mni <- closeLookup target
-- Forward the message if the target is in our close list.
forM_ mni $ \ni -> sendMessage dht ni m
await' pass
m -> pass m
|
