summaryrefslogtreecommitdiff
path: root/src/Network/Tox.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network/Tox.hs')
-rw-r--r--src/Network/Tox.hs456
1 files changed, 0 insertions, 456 deletions
diff --git a/src/Network/Tox.hs b/src/Network/Tox.hs
deleted file mode 100644
index 98c03b80..00000000
--- a/src/Network/Tox.hs
+++ /dev/null
@@ -1,456 +0,0 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE DeriveFoldable #-}
5{-# LANGUAGE DeriveFunctor #-}
6{-# LANGUAGE DeriveGeneric #-}
7{-# LANGUAGE DeriveTraversable #-}
8{-# LANGUAGE ExistentialQuantification #-}
9{-# LANGUAGE FlexibleInstances #-}
10{-# LANGUAGE GeneralizedNewtypeDeriving #-}
11{-# LANGUAGE LambdaCase #-}
12{-# LANGUAGE NamedFieldPuns #-}
13{-# LANGUAGE PatternSynonyms #-}
14{-# LANGUAGE RankNTypes #-}
15{-# LANGUAGE RecursiveDo #-}
16{-# LANGUAGE ScopedTypeVariables #-}
17{-# LANGUAGE TupleSections #-}
18{-# LANGUAGE ViewPatterns #-}
19module Network.Tox where
20
21#ifdef THREAD_DEBUG
22import Control.Concurrent.Lifted.Instrument
23#else
24import Control.Concurrent.Lifted
25#endif
26import Control.Concurrent.STM
27import Control.Exception (throwIO)
28import Control.Monad
29import Crypto.PubKey.Curve25519
30import Crypto.Random
31import Data.Bits.ByteString ()
32import qualified Data.ByteString as B
33 ;import Data.ByteString (ByteString)
34import qualified Data.ByteString.Char8 as C8
35import Data.Data
36import Data.Functor.Identity
37import Data.Functor.Contravariant
38import Data.Maybe
39import qualified Data.MinMaxPSQ as MinMaxPSQ
40import qualified Data.Serialize as S
41import Data.Time.Clock.POSIX (getPOSIXTime)
42import Data.Word
43import Network.Socket
44import System.Endian
45import System.IO.Error
46
47import Data.TableMethods
48import qualified Data.Word64Map
49import Network.BitTorrent.DHT.Token as Token
50import qualified Data.Wrapper.PSQ as PSQ
51import System.Global6
52import Network.Address (WantIP (..),IP,getBindAddress)
53import qualified Network.Kademlia.Routing as R
54import Network.QueryResponse
55import Crypto.Tox
56import Data.Word64Map (fitsInInt)
57import qualified Data.Word64Map (empty)
58import Network.Kademlia.Bootstrap (forkPollForRefresh, bootstrap)
59import Network.Tox.Crypto.Transport (Handshake(..),CryptoPacket)
60import qualified Network.Tox.DHT.Handlers as DHT
61import qualified Network.Tox.DHT.Transport as DHT
62import Network.Tox.NodeId
63import qualified Network.Tox.Onion.Handlers as Onion
64import qualified Network.Tox.Onion.Transport as Onion
65import Network.Tox.Transport
66import Network.Tox.TCP (tcpClient)
67import OnionRouter
68import Network.Tox.ContactInfo
69import Text.XXD
70import DPut
71import DebugTag
72import TCPProber
73import Network.Tox.Avahi
74import Network.Tox.Session
75import qualified Data.Tox.Relay as TCP
76import Network.Tox.Relay
77import Network.SessionTransports
78import Network.Kademlia.Search
79import HandshakeCache
80
81updateIP :: TVar (R.BucketList NodeInfo) -> SockAddr -> STM ()
82updateIP tblvar a = do
83 bkts <- readTVar tblvar
84 case nodeInfo (nodeId (R.thisNode bkts)) a of
85 Right ni -> writeTVar tblvar (bkts { R.thisNode = ni })
86 Left _ -> return ()
87
88genNonce24 :: DRG g =>
89 TVar (g, pending) -> DHT.TransactionId -> IO DHT.TransactionId
90genNonce24 var (DHT.TransactionId nonce8 _) = atomically $ do
91 (g,pending) <- readTVar var
92 let (bs, g') = randomBytesGenerate 24 g
93 writeTVar var (g',pending)
94 return $ DHT.TransactionId nonce8 (Nonce24 bs)
95
96
97gen :: forall gen. DRG gen => gen -> (DHT.TransactionId, gen)
98gen g = let (bs, g') = randomBytesGenerate 24 g
99 (ws, g'') = randomBytesGenerate 8 g'
100 Right w = S.runGet S.getWord64be ws
101 in ( DHT.TransactionId (Nonce8 w) (Nonce24 bs), g'' )
102
103intKey :: DHT.TransactionId -> Int
104intKey (DHT.TransactionId (Nonce8 w) _) = fromIntegral w
105
106w64Key :: DHT.TransactionId -> Word64
107w64Key (DHT.TransactionId (Nonce8 w) _) = w
108
109nonceKey :: DHT.TransactionId -> Nonce8
110nonceKey (DHT.TransactionId n _) = n
111
112-- | Return my own address.
113myAddr :: TVar (R.BucketList NodeInfo) -- ^ IPv4 buckets
114 -> TVar (R.BucketList NodeInfo) -- ^ IPv6 buckets
115 -> Maybe NodeInfo -- ^ Interested remote address
116 -> IO NodeInfo
117myAddr routing4 routing6 maddr = atomically $ do
118 let var = case flip DHT.prefer4or6 Nothing <$> maddr of
119 Just Want_IP6 -> routing4
120 _ -> routing6
121 a <- readTVar var
122 return $ R.thisNode a
123
124newClient :: (DRG g, Show addr, Show meth) =>
125 g -> Transport String addr x
126 -> (Client String meth DHT.TransactionId addr x
127 -> x
128 -> MessageClass String meth DHT.TransactionId addr x)
129 -> (Maybe addr -> IO addr)
130 -> (Client String meth DHT.TransactionId addr x
131 -> meth
132 -> Maybe (MethodHandler String DHT.TransactionId addr x))
133 -> (forall d. TransactionMethods d DHT.TransactionId addr x
134 -> TransactionMethods d DHT.TransactionId addr x)
135 -> (Client String meth DHT.TransactionId addr x
136 -> Transport String addr x -> Transport String addr x)
137 -> IO (Client String meth DHT.TransactionId addr x)
138newClient drg net classify selfAddr handlers modifytbl modifynet = do
139 -- If we have 8-byte keys for IntMap, then use it for transaction lookups.
140 -- Otherwise, use ordinary Map. The details of which will be hidden by an
141 -- existential closure (see mkclient below).
142 --
143 tblvar <-
144 if fitsInInt (Proxy :: Proxy Word64)
145 then do
146 let intmapT = transactionMethods (contramap intKey intMapMethods) gen
147 intmap_var <- atomically $ newTVar (drg, mempty)
148 return $ Right (intmapT,intmap_var)
149 else do
150 let word64mapT = transactionMethods (contramap w64Key w64MapMethods) gen
151 map_var <- atomically $ newTVar (drg, Data.Word64Map.empty)
152 return $ Left (word64mapT,map_var)
153 let dispatch tbl var handlers client = DispatchMethods
154 { classifyInbound = classify client
155 , lookupHandler = handlers -- var
156 , tableMethods = modifytbl tbl
157 }
158 eprinter = logErrors -- printErrors stderr
159 mkclient (tbl,var) handlers =
160 let client = Client
161 { clientNet = addHandler (reportParseError eprinter) (handleMessage client) $ modifynet client net
162 , clientDispatcher = dispatch tbl var (handlers client) client
163 , clientErrorReporter = eprinter
164 , clientPending = var
165 , clientAddress = selfAddr
166 , clientResponseId = genNonce24 var
167 }
168 in client
169 return $ either mkclient mkclient tblvar handlers
170
171data Tox extra = Tox
172 { toxDHT :: DHT.Client
173 , toxOnion :: Onion.Client RouteId
174 , toxToRoute :: Transport String Onion.AnnouncedRendezvous (PublicKey,Onion.OnionData)
175 , toxCrypto :: Transport String SockAddr (CryptoPacket Encrypted)
176 , toxHandshakes :: Transport String SockAddr (Handshake Encrypted)
177 , toxHandshakeCache :: HandshakeCache
178 , toxCryptoKeys :: TransportCrypto
179 , toxRouting :: DHT.Routing
180 , toxTokens :: TVar SessionTokens
181 , toxAnnouncedKeys :: TVar Onion.AnnouncedKeys
182 , toxOnionRoutes :: OnionRouter
183 , toxContactInfo :: ContactInfo extra
184 , toxAnnounceToLan :: IO ()
185 , toxBindAddress :: SockAddr
186 }
187
188
189
190-- | Create a DHTPublicKey packet to send to a remote contact.
191getContactInfo :: Tox extra -> IO DHT.DHTPublicKey
192getContactInfo Tox{toxCryptoKeys,toxRouting} = join $ atomically $ do
193 r4 <- readTVar $ DHT.routing4 toxRouting
194 r6 <- readTVar $ DHT.routing6 toxRouting
195 nonce <- transportNewNonce toxCryptoKeys
196 let self = nodeId n4
197 n4 = R.thisNode r4
198 n6 = R.thisNode r6
199 n4s = R.kclosest DHT.toxSpace 4 self r4
200 n6s = R.kclosest DHT.toxSpace 4 self r6
201 ns = filter (DHT.isGlobal . nodeIP) [n4,n6]
202 ++ concat (zipWith (\a b -> [a,b]) n4s n6s)
203 return $ do
204 timestamp <- round . (* 1000000) <$> getPOSIXTime
205 return DHT.DHTPublicKey
206 { dhtpkNonce = timestamp
207 , dhtpk = id2key self
208 , dhtpkNodes = DHT.SendNodes $ take 4 ns
209 }
210
211isLocalHost :: SockAddr -> Bool
212isLocalHost (SockAddrInet _ host32) = (fromBE32 host32 == 0x7f000001)
213isLocalHost _ = False
214
215addVerbosity :: Transport err SockAddr ByteString -> Transport err SockAddr ByteString
216addVerbosity tr =
217 tr { awaitMessage = \kont -> awaitMessage tr $ \m -> do
218 forM_ m $ mapM_ $ \(msg,addr) -> do
219 when (not (B.null msg || elem (B.head msg) [0,1,2,4,0x81,0x82,0x8c,0x8d])) $ do
220 mapM_ (\x -> dput XMisc ( (show addr) ++ " --> " ++ x))
221 $ xxd 0 msg
222 kont m
223 , sendMessage = \addr msg -> do
224 when (not (B.null msg || elem (B.head msg) [0,1,2,4,0x81,0x8c,0x8d])) $ do
225 mapM_ (\x -> dput XMisc ( (show addr) ++ " <-- " ++ x))
226 $ xxd 0 msg
227 sendMessage tr addr msg
228 }
229
230newKeysDatabase :: IO (TVar Onion.AnnouncedKeys)
231newKeysDatabase =
232 atomically $ newTVar $ Onion.AnnouncedKeys PSQ.empty MinMaxPSQ.empty
233
234
235getOnionAlias :: TransportCrypto -> STM NodeInfo -> Maybe (Onion.OnionDestination r) -> IO (Onion.OnionDestination r)
236getOnionAlias crypto dhtself remoteNode = atomically $ do
237 ni <- dhtself
238 let alias = case remoteNode of
239 Just (Onion.OnionDestination (Onion.AnnouncingAlias _ uk) _ _)
240 -> ni { nodeId = key2id uk }
241 _ -> ni { nodeId = key2id (onionAliasPublic crypto) }
242 return $ Onion.OnionDestination Onion.SearchingAlias alias Nothing
243
244newOnionClient :: DRG g =>
245 TransportCrypto
246 -> Transport String (Onion.OnionDestination RouteId) Onion.Message
247 -> DHT.Routing
248 -> TVar SessionTokens
249 -> TVar Onion.AnnouncedKeys
250 -> OnionRouter
251 -> TVar (g, Data.Word64Map.Word64Map a)
252 -> ((Maybe Onion.Message -> IO ()) -> a)
253 -> (a -> Maybe Onion.Message -> IO void)
254 -> Client String
255 DHT.PacketKind
256 DHT.TransactionId
257 (Onion.OnionDestination RouteId)
258 Onion.Message
259newOnionClient crypto net r toks keydb orouter map_var store load = c
260 where
261 eprinter = logErrors
262 c = Client
263 { clientNet = addHandler (reportParseError eprinter) (handleMessage c) net
264 , clientDispatcher = DispatchMethods
265 { classifyInbound = Onion.classify
266 , lookupHandler = Onion.handlers net r toks keydb
267 , tableMethods = hookQueries orouter DHT.transactionKey
268 $ transactionMethods' store load (contramap w64Key w64MapMethods) gen
269 }
270 , clientErrorReporter = eprinter
271 , clientPending = map_var
272 , clientAddress = getOnionAlias crypto $ R.thisNode <$> readTVar (DHT.routing4 r)
273 , clientResponseId = genNonce24 map_var
274 }
275
276newTox :: TVar Onion.AnnouncedKeys -- ^ Store of announced keys we are a rendezvous for.
277 -> [String] -- ^ Bind-address to listen on. Must provide at least one.
278 -> ( ContactInfo extra -> SockAddr -> Session -> IO () )
279 -> Maybe SecretKey -- ^ Optional DHT secret key to use.
280 -> ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses.
281 -> IO (Tox extra)
282newTox keydb bindspecs onsess suppliedDHTKey tcp = do
283 addrs <- mapM (`getBindAddress` True) bindspecs
284 let tryBind addr next _ = udpTransport' addr `catchIOError` (next . Just)
285 failedBind mbe = do
286 forM_ mbe $ \e -> do
287 dput XDHT $ "tox udp bind error: " ++ show addrs ++ " " ++ show e
288 throwIO e
289 throwIO $ userError "Tox UDP listen port?"
290 (udp,sock) <- foldr tryBind failedBind addrs Nothing
291 addr <- getSocketName sock
292 (relay,sendTCP) <- tcpRelay addr (\a x -> sendMessage udp a $ S.runPut $ Onion.putRequest x)
293 tox <- newToxOverTransport keydb addr onsess suppliedDHTKey udp sendTCP
294 return tox { toxAnnounceToLan = announceToLan sock (key2id $ transportPublic $ toxCryptoKeys tox) }
295
296-- | This version of 'newTox' is useful for automated tests using 'testPairTransport'.
297newToxOverTransport :: TVar Onion.AnnouncedKeys
298 -> SockAddr
299 -> ( ContactInfo extra -> SockAddr -> Session -> IO () )
300 -> Maybe SecretKey
301 -> Onion.UDPTransport
302 -> ( Int -> Onion.OnionMessage Encrypted -> IO () ) -- ^ TCP-bound onion responses.
303 -> IO (Tox extra)
304newToxOverTransport keydb addr onNewSession suppliedDHTKey udp tcp = do
305 roster <- newContactInfo
306 crypto0 <- newCrypto
307 let -- patch in supplied DHT key
308 crypto1 = fromMaybe crypto0 $do
309 k <- suppliedDHTKey
310 return crypto0
311 { transportSecret = k
312 , transportPublic = toPublic k
313 }
314 -- patch in newly allocated roster state.
315 crypto = crypto1 { userKeys = myKeyPairs roster }
316 forM_ suppliedDHTKey $ \k -> do
317 maybe (dput XMisc "failed to encode suppliedDHTKey")
318 (dputB XMisc . C8.append "Using suppliedDHTKey: ")
319 $ encodeSecret k
320
321 drg <- drgNew
322 let lookupClose _ = return Nothing
323
324 mkrouting <- DHT.newRouting addr crypto updateIP updateIP
325 (orouter,otbl) <- newOnionRouter crypto (dput XRoutes)
326 (cryptonet,dhtcrypt,onioncrypt,dtacrypt,handshakes)
327 <- toxTransport crypto orouter lookupClose udp
328 (\dst x -> sendMessage (clientNet $ tcpClient $ tcpKademliaClient orouter) dst (True,x))
329 tcp
330 sessions <- initSessions (sendMessage cryptonet)
331
332 let dhtnet0 = layerTransportM (DHT.decrypt crypto) (DHT.encrypt crypto) dhtcrypt
333 tbl4 = DHT.routing4 $ mkrouting (error "missing client")
334 tbl6 = DHT.routing6 $ mkrouting (error "missing client")
335 updateOnion bkts tr = hookBucketList DHT.toxSpace bkts orouter (trampolinesUDP orouter) tr
336 dhtclient <- newClient drg dhtnet0 DHT.classify (myAddr tbl4 tbl6) (DHT.handlers crypto . mkrouting) id
337 (\client net -> onInbound (DHT.updateRouting client (mkrouting client) updateOnion) net)
338
339 hscache <- newHandshakeCache crypto (sendMessage handshakes)
340 let sparams = SessionParams
341 { spCrypto = crypto
342 , spSessions = sessions
343 , spGetSentHandshake = getSentHandshake hscache
344 , spOnNewSession = onNewSession roster addr
345 }
346
347 -- TODO: Refactor so that these threads are forked when 'forkTox' is invoked.
348 -- This function should only initialize state.
349 orouter' <- forkRouteBuilder orouter
350 $ \nid ni -> fmap (\(_,ns,_)->ns)
351 <$> DHT.getNodes dhtclient (DHT.nodesOfInterest $ mkrouting dhtclient) nid ni
352
353 toks <- do
354 nil <- nullSessionTokens
355 atomically $ newTVar nil { maxInterval = 20 } -- 20 second timeout on announce ping-ids.
356 let onionnet = layerTransportM (Onion.decrypt crypto) (Onion.encrypt crypto) onioncrypt
357 let onionclient = newOnionClient crypto onionnet (mkrouting dhtclient) toks keydb orouter' otbl
358 Right $ \case
359 Right v -> v
360 Left v -> \_ ->
361 dput XUnexpected "TCP-sent onion query got response over UDP?"
362
363 return Tox
364 { toxDHT = dhtclient
365 , toxOnion = onionclient
366 , toxToRoute = onInbound (updateContactInfo roster) dtacrypt
367 , toxCrypto = addHandler (dput XMisc) (sessionHandler sessions) cryptonet
368 , toxHandshakes = addHandler (dput XMisc) (handshakeH sparams) handshakes
369 , toxHandshakeCache = hscache
370 , toxCryptoKeys = crypto
371 , toxRouting = mkrouting dhtclient
372 , toxTokens = toks
373 , toxAnnouncedKeys = keydb
374 , toxOnionRoutes = orouter' -- TODO: see above
375 , toxContactInfo = roster
376 , toxAnnounceToLan = return ()
377 , toxBindAddress = addr
378 }
379
380onionTimeout :: Tox extra -> DHT.TransactionId -> Onion.OnionDestination RouteId -> STM (Onion.OnionDestination RouteId, Int)
381onionTimeout Tox { toxOnionRoutes = or } (DHT.TransactionId n8 _) od = lookupTimeout or n8 od
382
383routing4nodeInfo :: DHT.Routing -> IO NodeInfo
384routing4nodeInfo (DHT.routing4 -> tv) = R.thisNode <$> readTVarIO tv
385
386dnssdAnnounce :: Tox extra -> IO ()
387dnssdAnnounce tox = do
388 ni <- routing4nodeInfo (toxRouting tox)
389 keys <- fmap (key2id . snd) <$> atomically (userKeys $ toxCryptoKeys tox)
390 announceToxService (nodePort ni) (nodeId ni) (listToMaybe keys)
391
392dnssdDiscover :: Tox extra -> NodeInfo -> (Maybe NodeId) -> IO ()
393dnssdDiscover tox ni toxid = do
394 acts <- atomically $ readTVar $ accounts $ toxContactInfo tox
395 now <- getPOSIXTime
396 forM toxid $ \tid ->
397 forM acts $ \act ->
398 atomically $ setContactAddr now (id2key tid) ni act
399
400 void $ DHT.ping (toxDHT tox) ni
401
402-- | Returns:
403--
404-- * action to shutdown this node, terminating all threads.
405--
406-- * action to bootstrap an IPv4 Kademlia table.
407--
408-- * action to bootstrap an IPv6 Kademlia table.
409forkTox :: Tox extra -> Bool -> IO (IO (), [NodeInfo] -> [NodeInfo] -> IO (), [NodeInfo] -> [NodeInfo] -> IO ())
410forkTox tox with_avahi = do
411 quitHs <- forkListener "toxHandshakes" (toxHandshakes tox)
412 quitToRoute <- forkListener "toxToRoute" (toxToRoute tox)
413 quitOnion <- forkListener "toxOnion" (clientNet $ toxOnion tox)
414 quitDHT <- forkListener "toxDHT" (clientNet $ toxDHT tox)
415 quitNC <- forkListener "toxCrypto" (toxCrypto tox)
416 quitTCP <- forkListener "relay-client" (clientNet $ tcpClient $ tcpKademliaClient $ toxOnionRoutes tox)
417 quitAvahi <- if with_avahi then do
418 forkPollForRefresh (DHT.refresher4 $ toxRouting tox)
419 forkPollForRefresh (DHT.refresher6 $ toxRouting tox)
420 dnssdIn <- forkIO $ queryToxService (dnssdDiscover tox)
421 dnssdOut <- forkIO $ dnssdAnnounce tox
422 labelThread dnssdIn "tox-avahi-monitor"
423 labelThread dnssdOut "tox-avahi-publish"
424 return $ forM_ [dnssdIn,dnssdOut] killThread
425 else return $ return ()
426 keygc <- Onion.forkAnnouncedKeysGC (toxAnnouncedKeys tox)
427 return ( do quitAvahi
428 killThread keygc
429 quitNC
430 quitDHT
431 quitOnion
432 quitTCP
433 quitRouteBuilder (toxOnionRoutes tox)
434 quitToRoute
435 quitHs
436 , bootstrap (DHT.refresher4 $ toxRouting tox)
437 , bootstrap (DHT.refresher6 $ toxRouting tox)
438 )
439
440-- TODO: Don't export this. The exported interface is 'toxAnnounceToLan'.
441announceToLan :: Socket -> NodeId -> IO ()
442announceToLan sock nid = do
443 addrs <- broadcastAddrs
444 forM_ addrs $ \addr -> do
445 (broadcast_info:_) <- getAddrInfo (Just defaultHints { addrFlags = [AI_NUMERICHOST], addrSocketType = Datagram })
446 (Just addr)
447 (Just "33445")
448 let broadcast = addrAddress broadcast_info
449 bs = S.runPut $ DHT.putMessage (DHT.DHTLanDiscovery nid)
450 dput XLan $ show broadcast ++ " <-- LanAnnounce " ++ show nid
451 saferSendTo sock bs broadcast
452
453
454toxQSearch :: Tox extra -> Search NodeId (IP, PortNumber) Nonce32 NodeInfo Onion.Rendezvous
455toxQSearch tox = Onion.toxidSearch (onionTimeout tox) (toxCryptoKeys tox) (toxOnion tox)
456
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-22 17:37:08 +0000