summaryrefslogtreecommitdiff
path: root/src/Network/Tox/DHT/Transport.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network/Tox/DHT/Transport.hs')
-rw-r--r--src/Network/Tox/DHT/Transport.hs370
1 files changed, 370 insertions, 0 deletions
diff --git a/src/Network/Tox/DHT/Transport.hs b/src/Network/Tox/DHT/Transport.hs
new file mode 100644
index 00000000..5a2d8a84
--- /dev/null
+++ b/src/Network/Tox/DHT/Transport.hs
@@ -0,0 +1,370 @@
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE KindSignatures #-}
3{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE StandaloneDeriving #-}
6{-# LANGUAGE TupleSections #-}
7{-# LANGUAGE TypeOperators #-}
8{-# LANGUAGE UndecidableInstances #-}
9module Network.Tox.DHT.Transport
10 ( parseDHTAddr
11 , encodeDHTAddr
12 , forwardDHTRequests
13 , module Network.Tox.Address
14 , DHTMessage(..)
15 , Ping(..)
16 , Pong(..)
17 , GetNodes(..)
18 , SendNodes(..)
19 , DHTPublicKey
20 , CookieRequest
21 , Cookie
22 , DHTRequest
23 , mapMessage
24 , encrypt
25 , decrypt
26 , dhtMessageType
27 ) where
28
29import Network.Tox.Address
30import Crypto.Tox hiding (encrypt,decrypt)
31import qualified Crypto.Tox as ToxCrypto
32import Network.QueryResponse
33
34import Control.Arrow
35import Control.Monad
36import Data.Bool
37import qualified Data.ByteString as B
38 ;import Data.ByteString (ByteString)
39import Data.Tuple
40import Data.Serialize as S
41import Data.Word
42import Network.Socket
43
44type DHTTransport = Transport String NodeInfo (DHTMessage Encrypted8)
45type HandleHi a = Maybe (Either String (DHTMessage Encrypted8, NodeInfo)) -> IO a
46
47
48data DHTMessage (f :: * -> *)
49 = DHTPing (Assym (f Ping))
50 | DHTPong (Assym (f Pong))
51 | DHTGetNodes (Assym (f GetNodes))
52 | DHTSendNodes (Assym (f SendNodes))
53 | DHTCookieRequest (Assym (f CookieRequest))
54 | DHTCookie Nonce24 (f Cookie)
55 | DHTDHTRequest PublicKey (Assym (f DHTRequest))
56
57deriving instance ( Show (f Cookie)
58 , Show (Assym (f Ping))
59 , Show (Assym (f Pong))
60 , Show (Assym (f GetNodes))
61 , Show (Assym (f SendNodes))
62 , Show (Assym (f CookieRequest))
63 , Show (Assym (f DHTRequest))
64 ) => Show (DHTMessage f)
65
66mapMessage :: forall f b. (forall a. Nonce24 -> f a -> b) -> DHTMessage f -> b
67mapMessage f (DHTPing a) = f (assymNonce a) (assymData a)
68mapMessage f (DHTPong a) = f (assymNonce a) (assymData a)
69mapMessage f (DHTGetNodes a) = f (assymNonce a) (assymData a)
70mapMessage f (DHTSendNodes a) = f (assymNonce a) (assymData a)
71mapMessage f (DHTCookieRequest a) = f (assymNonce a) (assymData a)
72mapMessage f (DHTDHTRequest _ a) = f (assymNonce a) (assymData a)
73mapMessage f (DHTCookie nonce fcookie) = f nonce fcookie
74
75
76instance Sized Ping where size = ConstSize 1
77instance Sized Pong where size = ConstSize 1
78
79parseDHTAddr :: (ByteString, SockAddr) -> Either (DHTMessage Encrypted8,NodeInfo) (ByteString,SockAddr)
80parseDHTAddr (msg,saddr)
81 | Just (typ,bs) <- B.uncons msg
82 , let right = Right (msg,saddr)
83 left = either (const right) Left
84 = case typ of
85 0x00 -> left $ direct bs saddr DHTPing
86 0x01 -> left $ direct bs saddr DHTPong
87 0x02 -> left $ direct bs saddr DHTGetNodes
88 0x04 -> left $ direct bs saddr DHTSendNodes
89 0x18 -> left $ direct bs saddr DHTCookieRequest
90 0x19 -> left $ fanGet bs getCookie (uncurry DHTCookie) (const $ noReplyAddr saddr)
91 0x20 -> left $ fanGet bs getDHTReqest (uncurry DHTDHTRequest) (asymNodeInfo saddr . snd)
92 _ -> right
93
94encodeDHTAddr :: (DHTMessage Encrypted8,NodeInfo) -> (ByteString, SockAddr)
95encodeDHTAddr (msg,ni) = (runPut $ putMessage msg, nodeAddr ni)
96
97dhtMessageType :: DHTMessage Encrypted8 -> ( Word8, Put )
98dhtMessageType (DHTPing a) = (0x00, putAssym a)
99dhtMessageType (DHTPong a) = (0x01, putAssym a)
100dhtMessageType (DHTGetNodes a) = (0x02, putAssym a)
101dhtMessageType (DHTSendNodes a) = (0x04, putAssym a)
102dhtMessageType (DHTCookieRequest a) = (0x18, putAssym a)
103dhtMessageType (DHTCookie n x) = (0x19, put n >> put x)
104dhtMessageType (DHTDHTRequest k a) = (0x20, putPublicKey k >> putAssym a)
105
106putMessage :: DHTMessage Encrypted8 -> Put
107putMessage msg = case dhtMessageType msg of (typ,p) -> put typ >> p
108
109getCookie :: Get (Nonce24, Encrypted8 Cookie)
110getCookie = get
111
112getDHTReqest :: Get (PublicKey, Assym (Encrypted8 DHTRequest))
113getDHTReqest = (,) <$> getPublicKey <*> getAssym
114
115-- ## DHT Request packets
116--
117-- | Length | Contents |
118-- |:-------|:--------------------------|
119-- | `1` | `uint8_t` (0x20) |
120-- | `32` | receiver's DHT public key |
121-- ... ...
122
123
124getDHT :: Sized a => Get (Assym (Encrypted8 a))
125getDHT = getAssym
126
127
128-- Throws an error if called with a non-internet socket.
129direct :: Sized a => ByteString
130 -> SockAddr
131 -> (Assym (Encrypted8 a) -> DHTMessage Encrypted8)
132 -> Either String (DHTMessage Encrypted8, NodeInfo)
133direct bs saddr f = fanGet bs getDHT f (asymNodeInfo saddr)
134
135-- Throws an error if called with a non-internet socket.
136asymNodeInfo :: SockAddr -> Assym a -> NodeInfo
137asymNodeInfo saddr asym = either (error . mappend "asymNodeInfo: ") id $ nodeInfo (key2id $ senderKey asym) saddr
138
139
140fanGet :: ByteString -> Get x -> (x -> a) -> (x -> b) -> Either String (a,b)
141fanGet bs getIt f nid = fmap (f &&& nid) $ runGet getIt bs
142
143-- Throws an error if called with a non-internet socket.
144noReplyAddr :: SockAddr -> NodeInfo
145noReplyAddr saddr = either (error . mappend "noReplyAddr: ") id $ nodeInfo zeroID saddr
146
147
148data DHTRequest
149-- #### NAT ping request
150--
151-- Length Contents
152-- :------- :-------------------------
153-- `1` `uint8_t` (0xfe)
154-- `1` `uint8_t` (0x00)
155-- `8` `uint64_t` random number
156 = NATPing Nonce8
157-- #### NAT ping response
158--
159-- Length Contents
160-- :------- :-----------------------------------------------------------------
161-- `1` `uint8_t` (0xfe)
162-- `1` `uint8_t` (0x01)
163-- `8` `uint64_t` random number (the same that was received in request)
164 | NATPong Nonce8
165 | DHTPK LongTermKeyWrap
166 deriving Show
167
168instance Sized DHTRequest where
169 size = VarSize $ \case
170 NATPing _ -> 10
171 NATPong _ -> 10
172 DHTPK wrap -> 1{-typ-} + 32{-key-} + 24{-nonce-}
173 + case size of
174 ConstSize n -> n
175 VarSize f -> f (wrapData wrap)
176
177instance Serialize DHTRequest where
178 get = do
179 tag <- get
180 case tag :: Word8 of
181 0xfe -> do
182 direction <- get
183 bool NATPong NATPing (direction==(0::Word8)) <$> get
184 0x9c -> DHTPK <$> get
185 _ -> fail ("unrecognized DHT request: "++show tag)
186 put (NATPing n) = put (0xfe00 :: Word16) >> put n
187 put (NATPong n) = put (0xfe01 :: Word16) >> put n
188 put (DHTPK pk) = put (0x9c :: Word8) >> put pk
189
190-- DHT public key packet:
191-- (As Onion data packet?)
192--
193-- | Length | Contents |
194-- |:------------|:------------------------------------|
195-- | `1` | `uint8_t` (0x9c) |
196-- | `8` | `uint64_t` `no_replay` |
197-- | `32` | Our DHT public key |
198-- | `[39, 204]` | Maximum of 4 nodes in packed format |
199data DHTPublicKey = DHTPublicKey
200 { dhtpkNonce :: Nonce8 -- no_replay
201 , dhtpk :: PublicKey -- dht public key
202 , dhtpkNodes :: SendNodes -- other reachable nodes
203 }
204
205-- When sent as a DHT request packet (this is the data sent in the DHT request
206-- packet):
207--
208-- Length Contents
209-- :--------- :-------------------------------
210-- `1` `uint8_t` (0x9c)
211-- `32` Long term public key of sender
212-- `24` Nonce
213-- variable Encrypted payload
214data LongTermKeyWrap = LongTermKeyWrap
215 { wrapLongTermKey :: PublicKey
216 , wrapNonce :: Nonce24
217 , wrapData :: Encrypted DHTPublicKey
218 }
219 deriving Show
220
221instance Serialize LongTermKeyWrap where
222 get = LongTermKeyWrap <$> getPublicKey <*> get <*> get
223 put (LongTermKeyWrap key nonce dta) = putPublicKey key >> put nonce >> put dta
224
225
226instance Sized DHTPublicKey where
227 -- NOTE: 41 bytes includes the 1-byte tag 0x9c in the size.
228 -- WARNING: Serialize instance does not include this byte FIXME
229 size = VarSize $ \(DHTPublicKey _ _ nodes) -> 41 + case size of
230 ConstSize nodes -> nodes
231 VarSize sznodes -> sznodes nodes
232
233instance Serialize DHTPublicKey where
234 -- TODO: This should agree with Sized instance.
235 get = DHTPublicKey <$> get <*> getPublicKey <*> get
236 put (DHTPublicKey nonce key nodes) = do
237 put nonce
238 putPublicKey key
239 put nodes
240
241newtype GetNodes = GetNodes NodeId
242 deriving (Eq,Ord,Show,Read,S.Serialize)
243
244instance Sized GetNodes where
245 size = ConstSize 32 -- TODO This right?
246
247newtype SendNodes = SendNodes [NodeInfo]
248 deriving (Eq,Ord,Show,Read)
249
250instance Sized SendNodes where
251 size = VarSize $ \(SendNodes ns) -> case size of
252 ConstSize nodeFormatSize -> nodeFormatSize * length ns
253 VarSize nsize -> sum $ map nsize ns
254
255instance S.Serialize SendNodes where
256 get = do
257 cnt <- S.get :: S.Get Word8
258 ns <- sequence $ replicate (fromIntegral cnt) S.get
259 return $ SendNodes ns
260
261 put (SendNodes ns) = do
262 let ns' = take 4 ns
263 S.put (fromIntegral (length ns') :: Word8)
264 mapM_ S.put ns'
265
266data Ping = Ping deriving Show
267data Pong = Pong deriving Show
268
269instance S.Serialize Ping where
270 get = do w8 <- S.get
271 if (w8 :: Word8) /= 0
272 then fail "Malformed ping."
273 else return Ping
274 put Ping = S.put (0 :: Word8)
275
276instance S.Serialize Pong where
277 get = do w8 <- S.get
278 if (w8 :: Word8) /= 1
279 then fail "Malformed pong."
280 else return Pong
281 put Pong = S.put (1 :: Word8)
282
283newtype CookieRequest = CookieRequest PublicKey
284 deriving (Eq, Show)
285newtype CookieResponse = CookieResponse Cookie
286 deriving (Eq, Show)
287
288data Cookie = Cookie Nonce24 (Encrypted CookieData)
289 deriving (Eq, Ord, Show)
290
291instance Sized Cookie where size = ConstSize 112 -- 24 byte nonce + 88 byte cookie data
292
293instance Serialize Cookie where
294 get = Cookie <$> get <*> get
295 put (Cookie nonce dta) = put nonce >> put dta
296
297data CookieData = CookieData -- 16 (mac)
298 { cookieTime :: Word64 -- 8
299 , longTermKey :: PublicKey -- 32
300 , dhtKey :: PublicKey -- + 32
301 } -- = 88 bytes when encrypted.
302
303instance Sized CookieData where
304 size = ConstSize 72
305
306instance Sized CookieRequest where
307 size = ConstSize 64 -- 32 byte key + 32 byte padding
308
309instance Serialize CookieRequest where
310 get = CookieRequest <$> getPublicKey <* {- padding -} getPublicKey
311 put (CookieRequest k) = putPublicKey k >> {- padding -} putPublicKey k
312
313forwardDHTRequests :: TransportCrypto -> (PublicKey -> IO (Maybe NodeInfo)) -> DHTTransport -> DHTTransport
314forwardDHTRequests crypto closeLookup dht = dht { awaitMessage = await' }
315 where
316 await' :: HandleHi a -> IO a
317 await' pass = awaitMessage dht $ \case
318 Just (Right (m@(DHTDHTRequest target payload),src)) | target /= transportPublic crypto
319 -> do mni <- closeLookup target
320 -- Forward the message if the target is in our close list.
321 forM_ mni $ \ni -> sendMessage dht ni m
322 await' pass
323 m -> pass m
324
325encrypt :: TransportCrypto -> DHTMessage ((,) Nonce8) -> NodeInfo -> (DHTMessage Encrypted8, NodeInfo)
326encrypt crypto msg ni = ( transcode (encryptMessage crypto (id2key $ nodeId ni)) msg
327 , ni )
328
329encryptMessage :: Serialize a =>
330 TransportCrypto ->
331 PublicKey ->
332 Nonce24 -> Either (Nonce8,a) (Assym (Nonce8,a)) -> Encrypted8 a
333encryptMessage crypto destKey n (Right assym) = E8 $ ToxCrypto.encrypt secret plain
334 where
335 secret = computeSharedSecret (transportSecret crypto) destKey n
336 plain = encodePlain $ swap $ assymData assym
337encryptMessage crypto destKey n (Left plain) = _todo -- need cached public key.
338
339decrypt :: TransportCrypto -> DHTMessage Encrypted8 -> NodeInfo -> Either String (DHTMessage ((,) Nonce8), NodeInfo)
340decrypt crypto msg ni = (, ni) <$> (sequenceMessage $ transcode (decryptMessage crypto) msg)
341
342decryptMessage :: Serialize x =>
343 TransportCrypto
344 -> Nonce24
345 -> Either (Encrypted8 x) (Assym (Encrypted8 x))
346 -> (Either String ∘ ((,) Nonce8)) x
347decryptMessage crypto n (Right assymE) = plain8 $ ToxCrypto.decrypt secret e
348 where
349 secret = computeSharedSecret (transportSecret crypto) (senderKey assymE) n
350 E8 e = assymData assymE
351 plain8 = Composed . fmap swap . (>>= decodePlain)
352decryptMessage crypto n (Left (E8 e)) = _todo -- need cached public key
353
354sequenceMessage :: Applicative m => DHTMessage (m ∘ f) -> m (DHTMessage f)
355sequenceMessage (DHTPing asym) = fmap DHTPing $ sequenceA $ fmap uncomposed asym
356sequenceMessage (DHTPong asym) = fmap DHTPong $ sequenceA $ fmap uncomposed asym
357sequenceMessage (DHTGetNodes asym) = fmap DHTGetNodes $ sequenceA $ fmap uncomposed asym
358sequenceMessage (DHTSendNodes asym) = fmap DHTSendNodes $ sequenceA $ fmap uncomposed asym
359sequenceMessage (DHTCookieRequest asym) = fmap DHTCookieRequest $ sequenceA $ fmap uncomposed asym
360sequenceMessage (DHTCookie n dta) = fmap (DHTCookie n) $ uncomposed dta
361sequenceMessage (DHTDHTRequest pubkey asym) = fmap (DHTDHTRequest pubkey) $ sequenceA $ fmap uncomposed asym
362
363transcode :: forall f g. (forall a. Serialize a => Nonce24 -> Either (f a) (Assym (f a)) -> g a) -> DHTMessage f -> DHTMessage g
364transcode f (DHTPing asym) = DHTPing $ asym { assymData = f (assymNonce asym) (Right asym) }
365transcode f (DHTPong asym) = DHTPong $ asym { assymData = f (assymNonce asym) (Right asym) }
366transcode f (DHTGetNodes asym) = DHTGetNodes $ asym { assymData = f (assymNonce asym) (Right asym) }
367transcode f (DHTSendNodes asym) = DHTSendNodes $ asym { assymData = f (assymNonce asym) (Right asym) }
368transcode f (DHTCookieRequest asym) = DHTCookieRequest $ asym { assymData = f (assymNonce asym) (Right asym) }
369transcode f (DHTCookie n dta) = DHTCookie n $ f n $ Left dta
370transcode f (DHTDHTRequest pubkey asym) = DHTDHTRequest pubkey $ asym { assymData = f (assymNonce asym) (Right asym) }
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 14:37:06 +0000