diff options
author | joe <joe@jerkface.net> | 2017-10-30 00:45:32 -0400 |
---|---|---|
committer | joe <joe@jerkface.net> | 2017-10-30 00:45:32 -0400 |
commit | 4b4266424a6b1d1fb57e29f6c331462d5abb80e1 (patch) | |
tree | dbfbce692d272f08362e9989a8fffeb676701cdd /src/Network/Tox/DHT/Handlers.hs | |
parent | 08c02ea307d056a2825d51699e1f2e111d41a7f0 (diff) |
Tox: LanDiscovery packet. Also: IsUnsolicited query/response
classification.
Diffstat (limited to 'src/Network/Tox/DHT/Handlers.hs')
-rw-r--r-- | src/Network/Tox/DHT/Handlers.hs | 36 |
1 files changed, 25 insertions, 11 deletions
diff --git a/src/Network/Tox/DHT/Handlers.hs b/src/Network/Tox/DHT/Handlers.hs index 6bbcfb43..d010f36d 100644 --- a/src/Network/Tox/DHT/Handlers.hs +++ b/src/Network/Tox/DHT/Handlers.hs | |||
@@ -22,6 +22,7 @@ import qualified Data.ByteString.Char8 as C8 | |||
22 | import qualified Data.ByteString.Base16 as Base16 | 22 | import qualified Data.ByteString.Base16 as Base16 |
23 | import Control.Arrow | 23 | import Control.Arrow |
24 | import Control.Monad | 24 | import Control.Monad |
25 | import Control.Concurrent.Lifted.Instrument | ||
25 | import Control.Concurrent.STM | 26 | import Control.Concurrent.STM |
26 | import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) | 27 | import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) |
27 | import Network.Socket | 28 | import Network.Socket |
@@ -87,9 +88,17 @@ instance Show PacketKind where | |||
87 | showsPrec d CookieResponseType = mappend "CookieResponseType" | 88 | showsPrec d CookieResponseType = mappend "CookieResponseType" |
88 | showsPrec d (PacketKind x) = mappend "PacketKind " . showsPrec (d+1) x | 89 | showsPrec d (PacketKind x) = mappend "PacketKind " . showsPrec (d+1) x |
89 | 90 | ||
90 | 91 | msgType :: ( Serialize (f DHTRequest) | |
91 | classify :: Message -> MessageClass String PacketKind TransactionId | 92 | , Serialize (f Cookie), Serialize (f CookieRequest) |
92 | classify msg = mapMessage (\nonce24 (nonce8,_) -> go msg (TransactionId nonce8 nonce24)) msg | 93 | , Serialize (f SendNodes), Serialize (f GetNodes) |
94 | , Serialize (f Pong), Serialize (f Ping) | ||
95 | ) => DHTMessage f -> PacketKind | ||
96 | msgType msg = PacketKind $ fst $ dhtMessageType msg | ||
97 | |||
98 | classify :: Client -> Message -> MessageClass String PacketKind TransactionId NodeInfo Message | ||
99 | classify client (DHTLanDiscovery {}) = IsUnsolicited (lanDiscoveryH client) | ||
100 | classify client msg = fromMaybe (IsUnknown "unknown") | ||
101 | $ mapMessage (\nonce24 (nonce8,_) -> go msg (TransactionId nonce8 nonce24)) msg | ||
93 | where | 102 | where |
94 | go (DHTPing {}) = IsQuery PingType | 103 | go (DHTPing {}) = IsQuery PingType |
95 | go (DHTGetNodes {}) = IsQuery GetNodesType | 104 | go (DHTGetNodes {}) = IsQuery GetNodesType |
@@ -202,6 +211,13 @@ cookieRequestH crypto ni (CookieRequest remoteUserKey) = do | |||
202 | edta = encryptSymmetric sym n24 dta | 211 | edta = encryptSymmetric sym n24 dta |
203 | return $ Cookie n24 edta | 212 | return $ Cookie n24 edta |
204 | 213 | ||
214 | lanDiscoveryH :: Client -> NodeInfo -> NodeInfo -> IO (Maybe (Message -> Message)) | ||
215 | lanDiscoveryH client _ ni = do | ||
216 | forkIO $ do | ||
217 | myThreadId >>= flip labelThread "lan-discover-ping" | ||
218 | ping client ni | ||
219 | return () | ||
220 | return Nothing | ||
205 | 221 | ||
206 | type Message = DHTMessage ((,) Nonce8) | 222 | type Message = DHTMessage ((,) Nonce8) |
207 | 223 | ||
@@ -295,11 +311,9 @@ getNodes client nid addr = do | |||
295 | return $ fmap unwrapNodes $ join reply | 311 | return $ fmap unwrapNodes $ join reply |
296 | 312 | ||
297 | updateRouting :: Client -> Routing -> OnionRouter -> NodeInfo -> Message -> IO () | 313 | updateRouting :: Client -> Routing -> OnionRouter -> NodeInfo -> Message -> IO () |
298 | updateRouting client routing orouter naddr msg = do | 314 | updateRouting client routing orouter naddr msg |
299 | let typ = fst $ dhtMessageType $ fst $ DHTTransport.encrypt (error "updateRouting") msg naddr | 315 | | PacketKind 0x21 <- msgType msg = return () -- ignore lan discovery |
300 | tid = mapMessage (\n24 (n8,_) -> TransactionId n8 n24) msg | 316 | | otherwise = do |
301 | -- hPutStrLn stderr $ "updateRouting "++show (typ,tid) | ||
302 | -- TODO: check msg type | ||
303 | case prefer4or6 naddr Nothing of | 317 | case prefer4or6 naddr Nothing of |
304 | Want_IP4 -> updateTable client naddr orouter (routing4 routing) (committee4 routing) (sched4 routing) | 318 | Want_IP4 -> updateTable client naddr orouter (routing4 routing) (committee4 routing) (sched4 routing) |
305 | Want_IP6 -> updateTable client naddr orouter (routing6 routing) (committee6 routing) (sched6 routing) | 319 | Want_IP6 -> updateTable client naddr orouter (routing6 routing) (committee6 routing) (sched6 routing) |
@@ -365,10 +379,10 @@ mkCookie (TransactionId n8 n24) src dst cookie = DHTCookie n24 (n8,cookie) | |||
365 | 379 | ||
366 | 380 | ||
367 | handlers :: TransportCrypto -> Routing -> PacketKind -> Maybe Handler | 381 | handlers :: TransportCrypto -> Routing -> PacketKind -> Maybe Handler |
368 | handlers _ routing PingType = Just $ MethodHandler (isPing snd) mkPong pingH | 382 | handlers _ routing PingType = Just $ MethodHandler (isPing snd) mkPong $ pingH |
369 | handlers _ routing GetNodesType = Just $ MethodHandler (isGetNodes snd) mkSendNodes $ getNodesH routing | 383 | handlers _ routing GetNodesType = Just $ MethodHandler (isGetNodes snd) mkSendNodes $ getNodesH routing |
370 | handlers crypto _ CookieRequestType = Just $ MethodHandler (isCookieRequest snd) mkCookie $ cookieRequestH crypto | 384 | handlers crypto _ CookieRequestType = Just $ MethodHandler (isCookieRequest snd) mkCookie $ cookieRequestH crypto |
371 | handlers _ _ _ = error "TODO handlers" | 385 | handlers _ _ _ = error "TODO handlers" |
372 | 386 | ||
373 | nodeSearch :: Client -> Search NodeId (IP,PortNumber) () NodeInfo NodeInfo | 387 | nodeSearch :: Client -> Search NodeId (IP,PortNumber) () NodeInfo NodeInfo |
374 | nodeSearch client = Search | 388 | nodeSearch client = Search |