summaryrefslogtreecommitdiff
path: root/src/Network
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network')
-rw-r--r--src/Network/QueryResponse.hs6
-rw-r--r--src/Network/Tox.hs17
-rw-r--r--src/Network/Tox/DHT/Handlers.hs41
-rw-r--r--src/Network/Tox/DHT/Transport.hs1
-rw-r--r--src/Network/Tox/Onion/Transport.hs4
5 files changed, 57 insertions, 12 deletions
diff --git a/src/Network/QueryResponse.hs b/src/Network/QueryResponse.hs
index 9563fa7c..fca6d5cc 100644
--- a/src/Network/QueryResponse.hs
+++ b/src/Network/QueryResponse.hs
@@ -27,7 +27,9 @@ import qualified Data.IntMap.Strict as IntMap
27 ;import Data.IntMap.Strict (IntMap) 27 ;import Data.IntMap.Strict (IntMap)
28import qualified Data.Map.Strict as Map 28import qualified Data.Map.Strict as Map
29 ;import Data.Map.Strict (Map) 29 ;import Data.Map.Strict (Map)
30import qualified Data.Word64Map as W64Map 30import qualified Data.Word64Map as W64Map
31 ;import Data.Word64Map (Word64Map)
32import Data.Word
31import Data.Maybe 33import Data.Maybe
32import Data.Typeable 34import Data.Typeable
33import Network.Socket 35import Network.Socket
@@ -333,7 +335,7 @@ intMapMethods :: TableMethods IntMap Int
333intMapMethods = TableMethods IntMap.insert IntMap.delete IntMap.lookup 335intMapMethods = TableMethods IntMap.insert IntMap.delete IntMap.lookup
334 336
335-- | Methods for using 'Data.Word64Map'. 337-- | Methods for using 'Data.Word64Map'.
336w64MapMethods :: TableMethods IntMap Int 338w64MapMethods :: TableMethods Word64Map Word64
337w64MapMethods = TableMethods W64Map.insert W64Map.delete W64Map.lookup 339w64MapMethods = TableMethods W64Map.insert W64Map.delete W64Map.lookup
338 340
339-- | Methods for using 'Data.Map' 341-- | Methods for using 'Data.Map'
diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
index c587578d..e9220fcb 100644
--- a/src/Network/Tox.hs
+++ b/src/Network/Tox.hs
@@ -87,6 +87,7 @@ import GHC.TypeLits
87 87
88import Crypto.Tox 88import Crypto.Tox
89import Data.Word64Map (fitsInInt) 89import Data.Word64Map (fitsInInt)
90import qualified Data.Word64Map (empty)
90import Network.Tox.Crypto.Transport (NetCrypto) 91import Network.Tox.Crypto.Transport (NetCrypto)
91import qualified Network.Tox.DHT.Handlers as DHT 92import qualified Network.Tox.DHT.Handlers as DHT
92import qualified Network.Tox.DHT.Transport as DHT 93import qualified Network.Tox.DHT.Transport as DHT
@@ -189,8 +190,8 @@ newClient drg net classify selfAddr handlers modifytbl modifynet = do
189 intmap_var <- atomically $ newTVar (drg, mempty) 190 intmap_var <- atomically $ newTVar (drg, mempty)
190 return $ Right (intmapT,intmap_var) 191 return $ Right (intmapT,intmap_var)
191 else do 192 else do
192 let word64mapT = transactionMethods (contramap w64key w64MapMethods) gen 193 let word64mapT = transactionMethods (contramap w64Key w64MapMethods) gen
193 map_var <- atomically $ newTVar (drg, mempty) 194 map_var <- atomically $ newTVar (drg, Data.Word64Map.empty)
194 return $ Left (word64mapT,map_var) 195 return $ Left (word64mapT,map_var)
195 let dispatch tbl var handlers = DispatchMethods 196 let dispatch tbl var handlers = DispatchMethods
196 { classifyInbound = classify 197 { classifyInbound = classify
@@ -236,12 +237,12 @@ getContactInfo Tox{toxCryptoKeys,toxRouting} = join $ atomically $ do
236 ns = filter (DHT.isGlobal . nodeIP) [n4,n6] 237 ns = filter (DHT.isGlobal . nodeIP) [n4,n6]
237 ++ concat (zipWith (\a b -> [a,b]) n4s n6s) 238 ++ concat (zipWith (\a b -> [a,b]) n4s n6s)
238 return $ do 239 return $ do
239 timestamp <- round . (* 1000000) <$> getPOSIXTime 240 timestamp <- round . (* 1000000) <$> getPOSIXTime
240 return DHT.DHTPublicKey 241 return DHT.DHTPublicKey
241 { dhtpkNonce = timestamp 242 { dhtpkNonce = timestamp
242 , dhtpk = id2key self 243 , dhtpk = id2key self
243 , dhtpkNodes = DHT.SendNodes $ take 4 ns 244 , dhtpkNodes = DHT.SendNodes $ take 4 ns
244 } 245 }
245 246
246isLocalHost :: SockAddr -> Bool 247isLocalHost :: SockAddr -> Bool
247isLocalHost (SockAddrInet _ host32) = (fromBE32 host32 == 0x7f000001) 248isLocalHost (SockAddrInet _ host32) = (fromBE32 host32 == 0x7f000001)
diff --git a/src/Network/Tox/DHT/Handlers.hs b/src/Network/Tox/DHT/Handlers.hs
index 9cdf0d06..840e2e6b 100644
--- a/src/Network/Tox/DHT/Handlers.hs
+++ b/src/Network/Tox/DHT/Handlers.hs
@@ -1,6 +1,7 @@
1{-# LANGUAGE GeneralizedNewtypeDeriving #-} 1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE PatternSynonyms #-} 2{-# LANGUAGE PatternSynonyms #-}
3{-# LANGUAGE TupleSections #-} 3{-# LANGUAGE TupleSections #-}
4{-# LANGUAGE CPP #-}
4module Network.Tox.DHT.Handlers where 5module Network.Tox.DHT.Handlers where
5 6
6import Network.Tox.DHT.Transport as DHTTransport 7import Network.Tox.DHT.Transport as DHTTransport
@@ -31,6 +32,7 @@ import Data.Maybe
31import Data.Bits 32import Data.Bits
32import Data.Serialize (Serialize) 33import Data.Serialize (Serialize)
33import Data.Word 34import Data.Word
35import Data.List
34import System.IO 36import System.IO
35 37
36data TransactionId = TransactionId 38data TransactionId = TransactionId
@@ -175,6 +177,7 @@ getNodesH routing addr (GetNodes nid) = do
175 ks6 <- go append6 $ routing6 routing 177 ks6 <- go append6 $ routing6 routing
176 let (ns1,ns2) = case preferred of Want_IP6 -> (ks6,ks) 178 let (ns1,ns2) = case preferred of Want_IP6 -> (ks6,ks)
177 Want_IP4 -> (ks,ks6) 179 Want_IP4 -> (ks,ks6)
180 Want_Both -> error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__
178 return $ SendNodes 181 return $ SendNodes
179 $ if null ns2 then ns1 182 $ if null ns2 then ns1
180 else take 4 (take 3 ns1 ++ ns2) 183 else take 4 (take 3 ns1 ++ ns2)
@@ -240,6 +243,42 @@ ping client addr = do
240 hPutStrLn stderr $ show addr ++ " -pong-> " ++ show reply 243 hPutStrLn stderr $ show addr ++ " -pong-> " ++ show reply
241 maybe (return False) (\Pong -> return True) $ join reply 244 maybe (return False) (\Pong -> return True) $ join reply
242 245
246cookieRequest :: TVar [(SockAddr,(Int,NodeInfo))] -> PublicKey -> Client -> NodeInfo -> IO (Maybe Cookie)
247cookieRequest tvar myDhtKey client addr = do
248 let sockAddr = nodeAddr addr
249 let incAddr sockMap
250 = case partition ((==sockAddr) . fst) sockMap of
251 ([],xs) -> insert (sockAddr, (1 ,addr)) xs
252 ([(_,(c,addr'))],xs) | addr' == addr -> insert (sockAddr, (c+1,addr)) xs
253 anythingElse -> error $ "unreachable at " ++ __FILE__ ++ show __LINE__ ++ show anythingElse ++ show (sockAddr,addr)
254 decAddr sockMap
255 = case partition ((==sockAddr) . fst) sockMap of
256 ([],xs) -> xs -- unreachable?
257 ([(_,(1,addr'))],xs) | addr' == addr -> xs
258 ([(_,(c,addr'))],xs) | addr' == addr -> insert (sockAddr,(c-1,addr)) xs
259 anythingElse -> error $ "unreachable at " ++ __FILE__ ++ show __LINE__ ++ show anythingElse ++ show (sockAddr,addr)
260 sockMap <- atomically $ do
261 mp <- incAddr <$> readTVar tvar
262 writeTVar tvar mp
263 return mp
264 let cookieSerializer
265 = MethodSerializer
266 { methodTimeout = \tid addr -> do
267 modifyTVar tvar decAddr
268 return (addr, 5000000)
269 , method = CookieRequestType
270 , wrapQuery = \tid src dst cr -> DHTCookieRequest $ wrapAsymm tid src dst (, cr)
271 , unwrapResponse = fmap snd . unCookie
272 }
273 cookieRequest = CookieRequest myDhtKey
274 hPutStrLn stderr $ show addr ++ " <-- cookieRequest"
275 reply <- QR.sendQuery client cookieSerializer cookieRequest addr
276 hPutStrLn stderr $ show addr ++ " -cookieResponse-> " ++ show reply
277 return $ join reply
278
279unCookie (DHTCookie n24 fcookie) = Just fcookie
280unCookie _ = Nothing
281
243unsendNodes :: Message -> Maybe (Asymm (Nonce8,SendNodes)) 282unsendNodes :: Message -> Maybe (Asymm (Nonce8,SendNodes))
244unsendNodes (DHTSendNodes asymm) = Just asymm 283unsendNodes (DHTSendNodes asymm) = Just asymm
245unsendNodes _ = Nothing 284unsendNodes _ = Nothing
@@ -263,6 +302,7 @@ updateRouting client routing orouter naddr msg = do
263 case prefer4or6 naddr Nothing of 302 case prefer4or6 naddr Nothing of
264 Want_IP4 -> updateTable client naddr orouter (routing4 routing) (committee4 routing) (sched4 routing) 303 Want_IP4 -> updateTable client naddr orouter (routing4 routing) (committee4 routing) (sched4 routing)
265 Want_IP6 -> updateTable client naddr orouter (routing6 routing) (committee6 routing) (sched6 routing) 304 Want_IP6 -> updateTable client naddr orouter (routing6 routing) (committee6 routing) (sched6 routing)
305 Want_Both -> error $ "BUG:unreachable at " ++ __FILE__ ++ ":" ++ show __LINE__
266 306
267updateTable :: Client -> NodeInfo -> OnionRouter -> TVar (R.BucketList NodeInfo) -> TriadCommittee NodeId SockAddr -> TVar (Int.PSQ POSIXTime) -> IO () 307updateTable :: Client -> NodeInfo -> OnionRouter -> TVar (R.BucketList NodeInfo) -> TriadCommittee NodeId SockAddr -> TVar (Int.PSQ POSIXTime) -> IO ()
268updateTable client naddr orouter tbl committee sched = do 308updateTable client naddr orouter tbl committee sched = do
@@ -327,6 +367,7 @@ handlers :: TransportCrypto -> Routing -> PacketKind -> Maybe Handler
327handlers _ routing PingType = Just $ MethodHandler (isPing snd) mkPong pingH 367handlers _ routing PingType = Just $ MethodHandler (isPing snd) mkPong pingH
328handlers _ routing GetNodesType = Just $ MethodHandler (isGetNodes snd) mkSendNodes $ getNodesH routing 368handlers _ routing GetNodesType = Just $ MethodHandler (isGetNodes snd) mkSendNodes $ getNodesH routing
329handlers crypto _ CookieRequestType = Just $ MethodHandler (isCookieRequest snd) mkCookie $ cookieRequestH crypto 369handlers crypto _ CookieRequestType = Just $ MethodHandler (isCookieRequest snd) mkCookie $ cookieRequestH crypto
370handlers _ _ _ = error "TODO handlers"
330 371
331nodeSearch :: Client -> Search NodeId (IP,PortNumber) () NodeInfo NodeInfo 372nodeSearch :: Client -> Search NodeId (IP,PortNumber) () NodeInfo NodeInfo
332nodeSearch client = Search 373nodeSearch client = Search
diff --git a/src/Network/Tox/DHT/Transport.hs b/src/Network/Tox/DHT/Transport.hs
index 5ebe8b15..79643fad 100644
--- a/src/Network/Tox/DHT/Transport.hs
+++ b/src/Network/Tox/DHT/Transport.hs
@@ -21,6 +21,7 @@ module Network.Tox.DHT.Transport
21 , NoSpam(..) 21 , NoSpam(..)
22 , verifyChecksum 22 , verifyChecksum
23 , CookieRequest(..) 23 , CookieRequest(..)
24 , CookieResponse(..)
24 , Cookie(..) 25 , Cookie(..)
25 , CookieData(..) 26 , CookieData(..)
26 , DHTRequest 27 , DHTRequest
diff --git a/src/Network/Tox/Onion/Transport.hs b/src/Network/Tox/Onion/Transport.hs
index 85cf095d..baadbbe8 100644
--- a/src/Network/Tox/Onion/Transport.hs
+++ b/src/Network/Tox/Onion/Transport.hs
@@ -681,8 +681,8 @@ decrypt :: TransportCrypto -> OnionMessage Encrypted -> OnionDestination r -> IO
681decrypt crypto msg addr = do 681decrypt crypto msg addr = do
682 (skey,pkey) <- selectKey crypto msg addr 682 (skey,pkey) <- selectKey crypto msg addr
683 return $ do 683 return $ do
684 msg <- sequenceMessage $ transcode (\n -> decryptMessage (skey,pkey) n . left (senderkey addr)) msg 684 msg <- sequenceMessage $ transcode (\n -> decryptMessage (skey,pkey) n . left (senderkey addr)) msg
685 Right (msg, addr) 685 Right (msg, addr)
686 686
687senderkey :: OnionDestination r -> t -> (PublicKey, t) 687senderkey :: OnionDestination r -> t -> (PublicKey, t)
688senderkey addr e = (onionKey addr, e) 688senderkey addr e = (onionKey addr, e)