summaryrefslogtreecommitdiff
path: root/src/Network/Tox/Onion/Handlers.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network/Tox/Onion/Handlers.hs')
-rw-r--r--src/Network/Tox/Onion/Handlers.hs369
1 files changed, 0 insertions, 369 deletions
diff --git a/src/Network/Tox/Onion/Handlers.hs b/src/Network/Tox/Onion/Handlers.hs
deleted file mode 100644
index f44dd79c..00000000
--- a/src/Network/Tox/Onion/Handlers.hs
+++ /dev/null
@@ -1,369 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE PatternSynonyms #-}
4module Network.Tox.Onion.Handlers where
5
6import Network.Kademlia.Search
7import Network.Tox.DHT.Transport
8import Network.Tox.DHT.Handlers hiding (Message,Client)
9import Network.Tox.Onion.Transport
10import Network.QueryResponse as QR hiding (Client)
11import qualified Network.QueryResponse as QR (Client)
12import Crypto.Tox
13import qualified Data.Wrapper.PSQ as PSQ
14 ;import Data.Wrapper.PSQ (PSQ,pattern (:->))
15import Control.Arrow
16
17import Data.Function
18import qualified Data.MinMaxPSQ as MinMaxPSQ
19 ;import Data.MinMaxPSQ (MinMaxPSQ')
20import Network.BitTorrent.DHT.Token as Token
21
22import Control.Exception hiding (Handler)
23import Control.Monad
24#ifdef THREAD_DEBUG
25import Control.Concurrent.Lifted.Instrument
26#else
27import Control.Concurrent
28import GHC.Conc (labelThread)
29#endif
30import Control.Concurrent.STM
31import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
32import Network.Socket
33#if MIN_VERSION_iproute(1,7,4)
34import Data.IP hiding (fromSockAddr)
35#else
36import Data.IP
37#endif
38import Data.Maybe
39import Data.Functor.Identity
40import DPut
41import DebugTag
42
43type Client r = QR.Client String PacketKind TransactionId (OnionDestination r) Message
44type Message = OnionMessage Identity
45
46classify :: Message -> MessageClass String PacketKind TransactionId (OnionDestination r) Message
47classify msg = go msg
48 where
49 go (OnionAnnounce announce) = IsQuery AnnounceType
50 $ TransactionId (snd $ runIdentity $ asymmData announce)
51 (asymmNonce announce)
52 go (OnionAnnounceResponse n8 n24 resp) = IsResponse (TransactionId n8 n24)
53 go (OnionToRoute {}) = IsQuery DataRequestType (TransactionId (Nonce8 0) (Nonce24 zeros24))
54 go (OnionToRouteResponse {}) = IsResponse (TransactionId (Nonce8 0) (Nonce24 zeros24))
55
56-- Toxcore generates `ping_id`s by taking a 32 byte sha hash of the current time,
57-- some secret bytes generated when the instance is created, the current time
58-- divided by a 20 second timeout, the public key of the requester and the source
59-- ip/port that the packet was received from. Since the ip/port that the packet
60-- was received from is in the `ping_id`, the announce packets being sent with a
61-- ping id must be sent using the same path as the packet that we received the
62-- `ping_id` from or announcing will fail.
63--
64-- The reason for this 20 second timeout in toxcore is that it gives a reasonable
65-- time (20 to 40 seconds) for a peer to announce himself while taking in count
66-- all the possible delays with some extra seconds.
67announceH :: Routing -> TVar SessionTokens -> TVar AnnouncedKeys -> OnionDestination r -> AnnounceRequest -> IO AnnounceResponse
68announceH routing toks keydb oaddr req = do
69 case () of
70 _ | announcePingId req == zeros32
71 -> go False
72
73 _ -> let Nonce32 bs = announcePingId req
74 tok = fromPaddedByteString 32 bs
75 in checkToken toks (onionNodeInfo oaddr) tok >>= go
76 `catch` (\(SomeException e) -> dput XAnnounce ("announceH Exception! "++show e) >> throw e)
77 where
78 go withTok = do
79 let naddr = onionNodeInfo oaddr
80 ns <- getNodesH routing naddr (GetNodes (announceSeeking req))
81 tm <- getPOSIXTime
82
83 let storing = case oaddr of
84 OnionToOwner _ pth -> guard (nodeId naddr == announceSeeking req) >> Just pth
85 _ -> Nothing
86 dput XAnnounce $ unlines [ "announceH: nodeId = " ++ show (nodeId naddr)
87 , " announceSeeking = " ++ show (announceSeeking req)
88 , " withTok = " ++ show withTok
89 , " storing = " ++ maybe "False" (const "True") storing
90 ]
91 record <- atomically $ do
92 forM_ storing $ \retpath -> when withTok $ do
93 let toxpath = AnnouncedRoute naddr{ nodeId = announceKey req } retpath
94 -- Note: The following distance calculation assumes that
95 -- our nodeid doesn't change and is the same for both
96 -- routing4 and routing6.
97 d = xorNodeId (nodeId (tentativeId routing))
98 (announceSeeking req)
99 modifyTVar' keydb (insertKey tm (announceSeeking req) toxpath d)
100 ks <- readTVar keydb
101 return $ snd . snd <$> MinMaxPSQ.lookup' (announceSeeking req) (keyAssoc ks)
102 newtok <- maybe (return $ zeros32)
103 (const $ Nonce32 . toPaddedByteString 32 <$> grantToken toks naddr)
104 storing
105 let k = case record of
106 Nothing -> NotStored newtok
107 Just _ | isJust storing -> Acknowledged newtok
108 Just (AnnouncedRoute ni _) -> SendBackKey $ id2key (nodeId ni)
109 let response = AnnounceResponse k ns
110 dput XAnnounce $ unwords ["Announce:", show req, "-reply->", show response]
111 return response
112
113dataToRouteH ::
114 TVar AnnouncedKeys
115 -> Transport err (OnionDestination r) (OnionMessage f)
116 -> addr
117 -> OnionMessage f
118 -> IO ()
119dataToRouteH keydb udp _ (OnionToRoute pub asymm) = do
120 let k = key2id pub
121 dput XOnion $ "dataToRouteH "++ show k
122 mb <- atomically $ do
123 ks <- readTVar keydb
124 forM (MinMaxPSQ.lookup' k (keyAssoc ks)) $ \(p,(cnt,rpath)) -> do
125 writeTVar keydb $ ks { keyAssoc = MinMaxPSQ.insert' k (cnt + 1, rpath) p (keyAssoc ks) }
126 return rpath
127 dput XOnion $ "dataToRouteH "++ show (fmap (const ()) mb)
128 forM_ mb $ \rpath -> do
129 -- forward
130 dput XOnion $ "dataToRouteH sendMessage"
131 sendMessage udp (toOnionDestination rpath) $ OnionToRouteResponse asymm
132 dput XOnion $ "Forwarding data-to-route -->"++show k
133
134type NodeDistance = NodeId
135
136data AnnouncedRoute = AnnouncedRoute NodeInfo (ReturnPath N3)
137
138toOnionDestination :: AnnouncedRoute -> OnionDestination r
139toOnionDestination (AnnouncedRoute ni rpath) = OnionToOwner ni rpath
140
141-- |
142-- The type 'NodeId' was originally made for the DHT key, but here
143-- we reuse it for user keys (public key/real key).
144--
145-- To find someone using their user (public) key, you search for it on
146-- kademlia. At each iteration of the search, you get a response with
147-- closest known nodes(DHT keys) to the key you are searching for.
148--
149-- To do an 'Announce' so your friends can find you, you do a search to
150-- find the closest nodes to your own user(public) key. At those nodes,
151-- you store a route back to yourself (using Announce message) so your
152-- friends can contact you. This means each node needs to store the
153-- saved routes, and that is the purpose of the 'AnnouncedKeys' data
154-- structure.
155--
156data AnnouncedKeys = AnnouncedKeys
157 { keyByAge :: !(PSQ NodeId (POSIXTime{-Time at which they announced to you-}))
158 , keyAssoc :: !(MinMaxPSQ' NodeId NodeDistance (Int{-count of route usage-},AnnouncedRoute))
159 -- ^ PSQ using NodeId(user/public key) as Key
160 -- and using 'NodeDistance' as priority.
161 -- (smaller number is higher priority)
162 --
163 -- Keeping in a MinMaxPSQ will help us later when we want to make the structure
164 -- bounded. (We simply throw away the most NodeDistant keys.
165 }
166
167
168insertKey :: POSIXTime -> NodeId -> AnnouncedRoute -> NodeDistance -> AnnouncedKeys -> AnnouncedKeys
169insertKey tm pub toxpath d keydb = AnnouncedKeys
170 { keyByAge = PSQ.insert pub tm (keyByAge keydb)
171 , keyAssoc = case MinMaxPSQ.lookup' pub (keyAssoc keydb) of
172 Just (_,(cnt,_)) -> MinMaxPSQ.insert' pub (cnt,toxpath) d (keyAssoc keydb)
173 Nothing -> MinMaxPSQ.insert' pub (0 ,toxpath) d (keyAssoc keydb)
174 }
175
176-- | Forks a thread to garbage-collect old key announcements. Keys may be
177-- discarded after 5 minutes.
178forkAnnouncedKeysGC :: TVar AnnouncedKeys -> IO ThreadId
179forkAnnouncedKeysGC db = forkIO $ do
180 myThreadId >>= flip labelThread "gc:toxids"
181 fix $ \loop -> do
182 cutoff <- getPOSIXTime
183 threadDelay 300000000 -- 300 seconds
184 join $ atomically $ do
185 fix $ \gc -> do
186 keys <- readTVar db
187 case PSQ.minView (keyByAge keys) of
188 Nothing -> return loop
189 Just (pub :-> tm,kba')
190 | tm > cutoff -> return loop
191 | otherwise -> do writeTVar db keys
192 { keyByAge = kba'
193 , keyAssoc = MinMaxPSQ.delete pub (keyAssoc keys)
194 }
195 gc
196
197areq :: Message -> Either String AnnounceRequest
198areq (OnionAnnounce asymm) = Right $ fst $ runIdentity $ asymmData asymm
199areq _ = Left "Unexpected non-announce OnionMessage"
200
201handlers :: Transport err (OnionDestination r) Message
202 -> Routing
203 -> TVar SessionTokens
204 -> TVar AnnouncedKeys
205 -> PacketKind
206 -> Maybe (MethodHandler String TransactionId (OnionDestination r) Message)
207handlers net routing toks keydb AnnounceType
208 = Just
209 $ MethodHandler areq (\(TransactionId n8 n24) src dst -> OnionAnnounceResponse n8 n24 . Identity)
210 $ announceH routing toks keydb
211handlers net _ _ keydb _ = Just $ NoReply Right $ dataToRouteH keydb net
212
213
214toxidSearch :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
215 -> TransportCrypto
216 -> Client r
217 -> Search NodeId (IP, PortNumber) Nonce32 NodeInfo Rendezvous
218toxidSearch getTimeout crypto client = Search
219 { searchSpace = toxSpace
220 , searchNodeAddress = nodeIP &&& nodePort
221 , searchQuery = Right $ asyncGetRendezvous getTimeout crypto client
222 , searchAlpha = 3
223 , searchK = 6
224 }
225
226announceSerializer :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
227 -> MethodSerializer
228 TransactionId
229 (OnionDestination r)
230 (OnionMessage Identity)
231 PacketKind
232 AnnounceRequest
233 (Maybe AnnounceResponse)
234announceSerializer getTimeout = MethodSerializer
235 { methodTimeout = getTimeout
236 , method = AnnounceType
237 , wrapQuery = \(TransactionId n8 n24) src dst req ->
238 -- :: tid -> addr -> addr -> a -> OnionMessage Identity
239 OnionAnnounce $ Asymm
240 { -- The public key is our real long term public key if we want to
241 -- announce ourselves, a temporary one if we are searching for
242 -- friends.
243 senderKey = onionKey src
244 , asymmNonce = n24
245 , asymmData = Identity (req, n8)
246 }
247 , unwrapResponse = \case -- :: OnionMessage Identity -> b
248 OnionAnnounceResponse _ _ resp -> Just $ runIdentity resp
249 _ -> Nothing
250 }
251
252unwrapAnnounceResponse :: Maybe NodeId -> NodeInfo -> AnnounceResponse -> ([NodeInfo], [Rendezvous], Maybe Nonce32)
253unwrapAnnounceResponse alias ni (AnnounceResponse is_stored (SendNodes ns))
254 = case is_stored of
255 NotStored n32 -> ( ns , [] , Just n32)
256 SendBackKey k -> ( ns , [Rendezvous k ni] , Nothing )
257 Acknowledged n32 -> ( ns , maybeToList $ fmap (\k -> Rendezvous (id2key k) ni) alias , Just n32)
258
259-- TODO Announce key to announce peers.
260--
261-- Announce Peers are only put in the 8 closest peers array if they respond
262-- to an announce request. If the peers fail to respond to 3 announce
263-- requests they are deemed timed out and removed.
264--
265-- ...
266--
267-- For this reason, after the peer is announced successfully for 17 seconds,
268-- announce packets are sent aggressively every 3 seconds to each known close
269-- peer (in the list of 8 peers) to search aggressively for peers that know
270-- the peer we are searching for.
271
272-- TODO
273-- If toxcore goes offline (no onion traffic for 20 seconds) toxcore will
274-- aggressively reannounce itself and search for friends as if it was just
275-- started.
276
277
278sendOnion :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
279 -> Client r
280 -> AnnounceRequest
281 -> OnionDestination r
282 -> (NodeInfo -> AnnounceResponse -> t)
283 -> IO (Maybe t)
284sendOnion getTimeout client req oaddr unwrap =
285 -- Four tries and then we tap out.
286 flip fix 4 $ \loop n -> do
287 mb <- QR.sendQuery client (announceSerializer getTimeout) req oaddr
288 forM_ mb $ \r -> dput XAnnounce $ show (onionNodeInfo oaddr) ++ " sent response: " ++ show r
289 maybe (if n>0 then loop $! n - 1 else return Nothing)
290 (return . Just . unwrap (onionNodeInfo oaddr))
291 $ join mb
292
293asyncOnion :: (TransactionId
294 -> OnionDestination r -> STM (OnionDestination r, Int))
295 -> QR.Client
296 err
297 PacketKind
298 TransactionId
299 (OnionDestination r)
300 (OnionMessage Identity)
301 -> AnnounceRequest
302 -> OnionDestination r
303 -> (NodeInfo -> AnnounceResponse -> a)
304 -> (Maybe a -> IO ())
305 -> IO ()
306asyncOnion getTimeout client req oaddr unwrap go =
307 -- Four tries and then we tap out.
308 flip fix 4 $ \loop n -> do
309 QR.asyncQuery client (announceSerializer getTimeout) req oaddr
310 $ \mb -> do
311 forM_ mb $ \r -> dput XAnnounce $ show (onionNodeInfo oaddr) ++ " sent response: " ++ show r
312 maybe (if n>0 then loop $! n - 1 else go Nothing)
313 (go . Just . unwrap (onionNodeInfo oaddr))
314 $ join mb
315
316
317-- | Lookup the secret counterpart for a given alias key.
318getRendezvous :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
319 -> TransportCrypto
320 -> Client r
321 -> NodeId
322 -> NodeInfo
323 -> IO (Maybe ([NodeInfo],[Rendezvous],Maybe Nonce32))
324getRendezvous getTimeout crypto client nid ni = do
325 asel <- atomically $ selectAlias crypto nid
326 let oaddr = OnionDestination asel ni Nothing
327 rkey = case asel of
328 SearchingAlias -> Nothing
329 _ -> Just $ key2id $ rendezvousPublic crypto
330 sendOnion getTimeout client
331 (AnnounceRequest zeros32 nid $ fromMaybe zeroID rkey)
332 oaddr
333 (unwrapAnnounceResponse rkey)
334
335asyncGetRendezvous
336 :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
337 -> TransportCrypto
338 -> Client r
339 -> NodeId
340 -> NodeInfo
341 -> (Maybe ([NodeInfo], [Rendezvous], Maybe Nonce32) -> IO ())
342 -> IO ()
343asyncGetRendezvous getTimeout crypto client nid ni go = do
344 asel <- atomically $ selectAlias crypto nid
345 let oaddr = OnionDestination asel ni Nothing
346 rkey = case asel of
347 SearchingAlias -> Nothing
348 _ -> Just $ key2id $ rendezvousPublic crypto
349 asyncOnion getTimeout client
350 (AnnounceRequest zeros32 nid $ fromMaybe zeroID rkey)
351 oaddr
352 (unwrapAnnounceResponse rkey)
353 go
354
355putRendezvous :: (TransactionId -> OnionDestination r -> STM (OnionDestination r, Int))
356 -> TransportCrypto
357 -> Client r
358 -> PublicKey
359 -> Nonce32
360 -> NodeInfo
361 -> IO (Maybe (Rendezvous, AnnounceResponse))
362putRendezvous getTimeout crypto client pubkey nonce32 ni = do
363 let longTermKey = key2id pubkey
364 rkey = rendezvousPublic crypto
365 rendezvousKey = key2id rkey
366 asel <- atomically $ selectAlias crypto longTermKey
367 let oaddr = OnionDestination asel ni Nothing
368 sendOnion getTimeout client (AnnounceRequest nonce32 longTermKey rendezvousKey) oaddr
369 $ \ni resp -> (Rendezvous rkey ni, resp)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 18:04:32 +0000