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.hs460
1 files changed, 0 insertions, 460 deletions
diff --git a/src/Network/Tox/DHT/Transport.hs b/src/Network/Tox/DHT/Transport.hs
deleted file mode 100644
index b9b63165..00000000
--- a/src/Network/Tox/DHT/Transport.hs
+++ /dev/null
@@ -1,460 +0,0 @@
1{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE KindSignatures #-}
6{-# LANGUAGE LambdaCase #-}
7{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE StandaloneDeriving #-}
9{-# LANGUAGE TupleSections #-}
10{-# LANGUAGE TypeOperators #-}
11{-# LANGUAGE UndecidableInstances #-}
12module Network.Tox.DHT.Transport
13 ( parseDHTAddr
14 , encodeDHTAddr
15 , forwardDHTRequests
16 , module Network.Tox.NodeId
17 , DHTMessage(..)
18 , Ping(..)
19 , Pong(..)
20 , GetNodes(..)
21 , SendNodes(..)
22 , DHTPublicKey(..)
23 , FriendRequest(..)
24 , NoSpam(..)
25 , CookieRequest(..)
26 , CookieResponse(..)
27 , Cookie(..)
28 , CookieData(..)
29 , DHTRequest
30 , mapMessage
31 , encrypt
32 , decrypt
33 , dhtMessageType
34 , asymNodeInfo
35 , putMessage -- Convenient for serializing DHTLanDiscovery
36 ) where
37
38import Network.Tox.NodeId
39import Crypto.Tox hiding (encrypt,decrypt)
40import qualified Crypto.Tox as ToxCrypto
41import Network.QueryResponse
42
43import Control.Applicative
44import Control.Arrow
45import Control.Concurrent.STM
46import Control.Monad
47import Data.Bool
48import qualified Data.ByteString as B
49 ;import Data.ByteString (ByteString)
50import Data.Functor.Contravariant
51import Data.Hashable
52import Data.Maybe
53import Data.Monoid
54import Data.Serialize as S
55import Data.Tuple
56import Data.Word
57import GHC.Generics
58import Network.Socket
59
60type DHTTransport = Transport String NodeInfo (DHTMessage Encrypted8)
61type HandleHi a = Maybe (Either String (DHTMessage Encrypted8, NodeInfo)) -> IO a
62
63
64data DHTMessage (f :: * -> *)
65 = DHTPing (Asymm (f Ping))
66 | DHTPong (Asymm (f Pong))
67 | DHTGetNodes (Asymm (f GetNodes))
68 | DHTSendNodes (Asymm (f SendNodes))
69 | DHTCookieRequest (Asymm (f CookieRequest))
70 | DHTCookie Nonce24 (f (Cookie Encrypted))
71 | DHTDHTRequest PublicKey (Asymm (f DHTRequest))
72 | DHTLanDiscovery NodeId
73
74deriving instance ( Show (f (Cookie Encrypted))
75 , Show (f Ping)
76 , Show (f Pong)
77 , Show (f GetNodes)
78 , Show (f SendNodes)
79 , Show (f CookieRequest)
80 , Show (f DHTRequest)
81 ) => Show (DHTMessage f)
82
83mapMessage :: forall f b. (forall a. Nonce24 -> f a -> b) -> DHTMessage f -> Maybe b
84mapMessage f (DHTPing a) = Just $ f (asymmNonce a) (asymmData a)
85mapMessage f (DHTPong a) = Just $ f (asymmNonce a) (asymmData a)
86mapMessage f (DHTGetNodes a) = Just $ f (asymmNonce a) (asymmData a)
87mapMessage f (DHTSendNodes a) = Just $ f (asymmNonce a) (asymmData a)
88mapMessage f (DHTCookieRequest a) = Just $ f (asymmNonce a) (asymmData a)
89mapMessage f (DHTDHTRequest _ a) = Just $ f (asymmNonce a) (asymmData a)
90mapMessage f (DHTCookie nonce fcookie) = Just $ f nonce fcookie
91mapMessage f (DHTLanDiscovery nid) = Nothing
92
93
94instance Sized Ping where size = ConstSize 1
95instance Sized Pong where size = ConstSize 1
96
97parseDHTAddr :: TransportCrypto -> (ByteString, SockAddr) -> IO (Either (DHTMessage Encrypted8,NodeInfo) (ByteString,SockAddr))
98parseDHTAddr crypto (msg,saddr)
99 | Just (typ,bs) <- B.uncons msg
100 , let right = return $ Right (msg,saddr)
101 left = either (const right) (return . Left)
102 = case typ of
103 0x00 -> left $ direct bs saddr DHTPing
104 0x01 -> left $ direct bs saddr DHTPong
105 0x02 -> left $ direct bs saddr DHTGetNodes
106 0x04 -> left $ direct bs saddr DHTSendNodes
107 0x18 -> left $ direct bs saddr DHTCookieRequest
108 0x19 -> do
109 cs <- atomically $ readTVar (pendingCookies crypto)
110 let ni = fromMaybe (noReplyAddr saddr) $ do
111 (cnt,key) <- lookup saddr cs <|> listToMaybe (map snd cs)
112 either (const Nothing) Just $ nodeInfo (key2id key) saddr
113 left $ fanGet bs getCookie (uncurry DHTCookie) (const $ ni)
114 0x20 -> left $ fanGet bs getDHTReqest (uncurry DHTDHTRequest) (asymNodeInfo saddr . snd)
115 0x21 -> left $ do
116 nid <- runGet get bs
117 ni <- nodeInfo nid saddr
118 return (DHTLanDiscovery nid, ni)
119 _ -> right
120
121encodeDHTAddr :: (DHTMessage Encrypted8,NodeInfo) -> IO (ByteString, SockAddr)
122encodeDHTAddr (msg,ni) = return (runPut $ putMessage msg, nodeAddr ni)
123
124dhtMessageType :: ( Serialize (f DHTRequest)
125 , Serialize (f (Cookie Encrypted)), Serialize (f CookieRequest)
126 , Serialize (f SendNodes), Serialize (f GetNodes)
127 , Serialize (f Pong), Serialize (f Ping)
128 ) => DHTMessage f -> (Word8, Put)
129dhtMessageType (DHTPing a) = (0x00, putAsymm a)
130dhtMessageType (DHTPong a) = (0x01, putAsymm a)
131dhtMessageType (DHTGetNodes a) = (0x02, putAsymm a)
132dhtMessageType (DHTSendNodes a) = (0x04, putAsymm a)
133dhtMessageType (DHTCookieRequest a) = (0x18, putAsymm a)
134dhtMessageType (DHTCookie n x) = (0x19, put n >> put x)
135dhtMessageType (DHTDHTRequest k a) = (0x20, putPublicKey k >> putAsymm a)
136dhtMessageType (DHTLanDiscovery nid) = (0x21, put nid)
137
138putMessage :: DHTMessage Encrypted8 -> Put
139putMessage msg = case dhtMessageType msg of (typ,p) -> put typ >> p
140
141getCookie :: Get (Nonce24, Encrypted8 (Cookie Encrypted))
142getCookie = get
143
144getDHTReqest :: Get (PublicKey, Asymm (Encrypted8 DHTRequest))
145getDHTReqest = (,) <$> getPublicKey <*> getAsymm
146
147-- ## DHT Request packets
148--
149-- | Length | Contents |
150-- |:-------|:--------------------------|
151-- | `1` | `uint8_t` (0x20) |
152-- | `32` | receiver's DHT public key |
153-- ... ...
154
155
156getDHT :: Sized a => Get (Asymm (Encrypted8 a))
157getDHT = getAsymm
158
159
160-- Throws an error if called with a non-internet socket.
161direct :: Sized a => ByteString
162 -> SockAddr
163 -> (Asymm (Encrypted8 a) -> DHTMessage Encrypted8)
164 -> Either String (DHTMessage Encrypted8, NodeInfo)
165direct bs saddr f = fanGet bs getDHT f (asymNodeInfo saddr)
166
167-- Throws an error if called with a non-internet socket.
168asymNodeInfo :: SockAddr -> Asymm a -> NodeInfo
169asymNodeInfo saddr asym = either (error . mappend "asymNodeInfo: ") id $ nodeInfo (key2id $ senderKey asym) saddr
170
171
172fanGet :: ByteString -> Get x -> (x -> a) -> (x -> b) -> Either String (a,b)
173fanGet bs getIt f nid = fmap (f &&& nid) $ runGet getIt bs
174
175-- Throws an error if called with a non-internet socket.
176noReplyAddr :: SockAddr -> NodeInfo
177noReplyAddr saddr = either (error . mappend "noReplyAddr: ") id $ nodeInfo zeroID saddr
178
179
180data DHTRequest
181 -- #### NAT ping request
182 --
183 -- Length Contents
184 -- :------- :-------------------------
185 -- `1` `uint8_t` (0xfe)
186 -- `1` `uint8_t` (0x00)
187 -- `8` `uint64_t` random number
188 = NATPing Nonce8
189 -- #### NAT ping response
190 --
191 -- Length Contents
192 -- :------- :-----------------------------------------------------------------
193 -- `1` `uint8_t` (0xfe)
194 -- `1` `uint8_t` (0x01)
195 -- `8` `uint64_t` random number (the same that was received in request)
196 | NATPong Nonce8
197 | DHTPK LongTermKeyWrap
198 -- From docs/Hardening_docs.txt
199 --
200 -- All hardening requests must contain exactly 384 bytes of data. (The data sent
201 -- must be padded with zeros if it is smaller than that.)
202 --
203 -- [byte with value: 02 (get nodes test request)][struct Node_format (the node to
204 -- test.)][client_id(32 bytes) the id to query the node with.][padding]
205 --
206 -- packet id: CRYPTO_PACKET_HARDENING (48)
207 | Hardening -- TODO
208 deriving Show
209
210instance Sized DHTRequest where
211 size = VarSize $ \case
212 NATPing _ -> 10
213 NATPong _ -> 10
214 DHTPK wrap -> 1{-typ-} + 32{-key-} + 24{-nonce-}
215 + case size of
216 ConstSize n -> n
217 VarSize f -> f (wrapData wrap)
218 Hardening -> 1{-typ-} + 384
219
220instance Serialize DHTRequest where
221 get = do
222 tag <- get
223 case tag :: Word8 of
224 0xfe -> do
225 direction <- get
226 bool NATPong NATPing (direction==(0::Word8)) <$> get
227 0x9c -> DHTPK <$> get
228 0x30 -> pure Hardening -- TODO: CRYPTO_PACKET_HARDENING
229 _ -> fail ("unrecognized DHT request: "++show tag)
230 put (NATPing n) = put (0xfe00 :: Word16) >> put n
231 put (NATPong n) = put (0xfe01 :: Word16) >> put n
232 put (DHTPK pk) = put (0x9c :: Word8) >> put pk
233 put (Hardening) = put (0x30 :: Word8) >> putByteString (B.replicate 384 0) -- TODO
234
235-- DHT public key packet:
236-- (As Onion data packet?)
237--
238-- | Length | Contents |
239-- |:------------|:------------------------------------|
240-- | `1` | `uint8_t` (0x9c) |
241-- | `8` | `uint64_t` `no_replay` |
242-- | `32` | Our DHT public key |
243-- | `[39, 204]` | Maximum of 4 nodes in packed format |
244data DHTPublicKey = DHTPublicKey
245 { dhtpkNonce :: Word64 -- ^ The `no_replay` number is protection if
246 -- someone tries to replay an older packet and
247 -- should be set to an always increasing number.
248 -- It is 8 bytes so you should set a high
249 -- resolution monotonic time as the value.
250 , dhtpk :: PublicKey -- dht public key
251 , dhtpkNodes :: SendNodes -- other reachable nodes
252 }
253 deriving (Eq, Show)
254
255
256-- int8_t (0x20 sent over onion, 0x12 for sent over net_crypto)
257-- [uint32_t nospam][Message (UTF8) 1 to ONION_CLIENT_MAX_DATA_SIZE bytes]
258data FriendRequest = FriendRequest
259 { friendNoSpam :: Word32
260 , friendRequestText :: ByteString -- UTF8
261 }
262 deriving (Eq, Ord, Show)
263
264
265-- When sent as a DHT request packet (this is the data sent in the DHT request
266-- packet):
267--
268-- Length Contents
269-- :--------- :-------------------------------
270-- `1` `uint8_t` (0x9c)
271-- `32` Long term public key of sender
272-- `24` Nonce
273-- variable Encrypted payload
274data LongTermKeyWrap = LongTermKeyWrap
275 { wrapLongTermKey :: PublicKey
276 , wrapNonce :: Nonce24
277 , wrapData :: Encrypted DHTPublicKey
278 }
279 deriving Show
280
281instance Serialize LongTermKeyWrap where
282 get = LongTermKeyWrap <$> getPublicKey <*> get <*> get
283 put (LongTermKeyWrap key nonce dta) = putPublicKey key >> put nonce >> put dta
284
285
286instance Sized DHTPublicKey where
287 -- NOTE: 41 bytes includes the 1-byte tag 0x9c in the size.
288 -- WARNING: Serialize instance does not include this byte FIXME
289 size = VarSize $ \(DHTPublicKey _ _ nodes) -> 41 + case size of
290 ConstSize nodes -> nodes
291 VarSize sznodes -> sznodes nodes
292
293instance Sized Word32 where size = ConstSize 4
294
295-- FIXME: Inconsitently, this type does not include the 0x20 or 0x12 tag byte
296-- where the DHTPublicKey type does include its tag.
297instance Sized FriendRequest where
298 size = contramap friendNoSpam size <> contramap friendRequestText (VarSize B.length)
299
300instance Serialize DHTPublicKey where
301 -- TODO: This should agree with Sized instance.
302 get = DHTPublicKey <$> get <*> getPublicKey <*> get
303 put (DHTPublicKey nonce key nodes) = do
304 put nonce
305 putPublicKey key
306 put nodes
307
308instance Serialize FriendRequest where
309 get = FriendRequest <$> get <*> (remaining >>= getBytes)
310 put (FriendRequest nospam txt) = put nospam >> putByteString txt
311
312newtype GetNodes = GetNodes NodeId
313 deriving (Eq,Ord,Show,Read,S.Serialize)
314
315instance Sized GetNodes where
316 size = ConstSize 32 -- TODO This right?
317
318newtype SendNodes = SendNodes [NodeInfo]
319 deriving (Eq,Ord,Show,Read)
320
321instance Sized SendNodes where
322 size = VarSize $ \(SendNodes ns) -> case size of
323 ConstSize nodeFormatSize -> nodeFormatSize * length ns
324 VarSize nsize -> sum $ map nsize ns
325
326instance S.Serialize SendNodes where
327 get = do
328 cnt <- S.get :: S.Get Word8
329 ns <- sequence $ replicate (fromIntegral cnt) S.get
330 return $ SendNodes ns
331
332 put (SendNodes ns) = do
333 let ns' = take 4 ns
334 S.put (fromIntegral (length ns') :: Word8)
335 mapM_ S.put ns'
336
337data Ping = Ping deriving Show
338data Pong = Pong deriving Show
339
340instance S.Serialize Ping where
341 get = do w8 <- S.get
342 if (w8 :: Word8) /= 0
343 then fail "Malformed ping."
344 else return Ping
345 put Ping = S.put (0 :: Word8)
346
347instance S.Serialize Pong where
348 get = do w8 <- S.get
349 if (w8 :: Word8) /= 1
350 then fail "Malformed pong."
351 else return Pong
352 put Pong = S.put (1 :: Word8)
353
354newtype CookieRequest = CookieRequest PublicKey
355 deriving (Eq, Show)
356newtype CookieResponse = CookieResponse (Cookie Encrypted)
357 deriving (Eq, Show)
358
359data Cookie (f :: * -> *) = Cookie Nonce24 (f CookieData)
360
361deriving instance Eq (f CookieData) => Eq (Cookie f)
362deriving instance Ord (f CookieData) => Ord (Cookie f)
363deriving instance Show (f CookieData) => Show (Cookie f)
364deriving instance Generic (f CookieData) => Generic (Cookie f)
365
366instance Hashable (Cookie Encrypted)
367
368instance Sized (Cookie Encrypted) where size = ConstSize 112 -- 24 byte nonce + 88 byte cookie data
369
370instance Serialize (Cookie Encrypted) where
371 get = Cookie <$> get <*> get
372 put (Cookie nonce dta) = put nonce >> put dta
373
374data CookieData = CookieData -- 16 (mac)
375 { cookieTime :: Word64 -- 8
376 , longTermKey :: PublicKey -- 32
377 , dhtKey :: PublicKey -- + 32
378 } -- = 88 bytes when encrypted.
379 deriving (Show, Generic)
380
381instance Sized CookieData where
382 size = ConstSize 72
383
384instance Serialize CookieData where
385 get = CookieData <$> get <*> getPublicKey <*> getPublicKey
386 put (CookieData tm userkey dhtkey) = do
387 put tm
388 putPublicKey userkey
389 putPublicKey userkey
390
391instance Sized CookieRequest where
392 size = ConstSize 64 -- 32 byte key + 32 byte padding
393
394instance Serialize CookieRequest where
395 get = CookieRequest <$> getPublicKey <* {- padding -} getPublicKey
396 put (CookieRequest k) = putPublicKey k >> {- padding -} putPublicKey k
397
398forwardDHTRequests :: TransportCrypto -> (PublicKey -> IO (Maybe NodeInfo)) -> DHTTransport -> DHTTransport
399forwardDHTRequests crypto closeLookup dht = dht { awaitMessage = await' }
400 where
401 await' :: HandleHi a -> IO a
402 await' pass = awaitMessage dht $ \case
403 Just (Right (m@(DHTDHTRequest target payload),src)) | target /= transportPublic crypto
404 -> do mni <- closeLookup target
405 -- Forward the message if the target is in our close list.
406 forM_ mni $ \ni -> sendMessage dht ni m
407 await' pass
408 m -> pass m
409
410encrypt :: TransportCrypto -> DHTMessage ((,) Nonce8) -> NodeInfo -> IO (DHTMessage Encrypted8, NodeInfo)
411encrypt crypto msg ni = do
412 let cipher n plain = Composed $ encryptMessage crypto (id2key $ nodeId ni) n plain
413 m <- sequenceMessage $ transcode cipher msg
414 return (m, ni)
415
416encryptMessage :: Serialize a =>
417 TransportCrypto ->
418 PublicKey ->
419 Nonce24 -> Either (Nonce8,a) (Asymm (Nonce8,a)) -> IO (Encrypted8 a)
420encryptMessage crypto destKey n arg = do
421 let plain = encodePlain $ swap $ either id asymmData arg
422 secret <- lookupSharedSecret crypto (transportSecret crypto) destKey n
423 return $ E8 $ ToxCrypto.encrypt secret plain
424
425decrypt :: TransportCrypto -> DHTMessage Encrypted8 -> NodeInfo -> IO (Either String (DHTMessage ((,) Nonce8), NodeInfo))
426decrypt crypto msg ni = do
427 let decipher n c = Composed $ decryptMessage crypto n . left ((,) $ id2key $ nodeId ni) $ c
428 msg' <- sequenceMessage $ transcode decipher msg
429 return $ fmap (, ni) $ sequenceMessage msg'
430
431decryptMessage :: Serialize x =>
432 TransportCrypto
433 -> Nonce24
434 -> Either (PublicKey, Encrypted8 x) (Asymm (Encrypted8 x))
435 -> IO ((Either String ∘ ((,) Nonce8)) x)
436decryptMessage crypto n arg = do
437 let (remotekey,E8 e) = either id (senderKey &&& asymmData) arg
438 plain8 = Composed . fmap swap . (>>= decodePlain)
439 secret <- lookupSharedSecret crypto (transportSecret crypto) remotekey n
440 return $ plain8 $ ToxCrypto.decrypt secret e
441
442sequenceMessage :: Applicative m => DHTMessage (m ∘ f) -> m (DHTMessage f)
443sequenceMessage (DHTPing asym) = fmap DHTPing $ sequenceA $ fmap uncomposed asym
444sequenceMessage (DHTPong asym) = fmap DHTPong $ sequenceA $ fmap uncomposed asym
445sequenceMessage (DHTGetNodes asym) = fmap DHTGetNodes $ sequenceA $ fmap uncomposed asym
446sequenceMessage (DHTSendNodes asym) = fmap DHTSendNodes $ sequenceA $ fmap uncomposed asym
447sequenceMessage (DHTCookieRequest asym) = fmap DHTCookieRequest $ sequenceA $ fmap uncomposed asym
448sequenceMessage (DHTCookie n dta) = fmap (DHTCookie n) $ uncomposed dta
449sequenceMessage (DHTDHTRequest pubkey asym) = fmap (DHTDHTRequest pubkey) $ sequenceA $ fmap uncomposed asym
450sequenceMessage (DHTLanDiscovery nid) = pure $ DHTLanDiscovery nid
451
452transcode :: forall f g. (forall a. Serialize a => Nonce24 -> Either (f a) (Asymm (f a)) -> g a) -> DHTMessage f -> DHTMessage g
453transcode f (DHTPing asym) = DHTPing $ asym { asymmData = f (asymmNonce asym) (Right asym) }
454transcode f (DHTPong asym) = DHTPong $ asym { asymmData = f (asymmNonce asym) (Right asym) }
455transcode f (DHTGetNodes asym) = DHTGetNodes $ asym { asymmData = f (asymmNonce asym) (Right asym) }
456transcode f (DHTSendNodes asym) = DHTSendNodes $ asym { asymmData = f (asymmNonce asym) (Right asym) }
457transcode f (DHTCookieRequest asym) = DHTCookieRequest $ asym { asymmData = f (asymmNonce asym) (Right asym) }
458transcode f (DHTCookie n dta) = DHTCookie n $ f n $ Left dta
459transcode f (DHTDHTRequest pubkey asym) = DHTDHTRequest pubkey $ asym { asymmData = f (asymmNonce asym) (Right asym) }
460transcode f (DHTLanDiscovery nid) = DHTLanDiscovery nid
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 17:06:47 +0000