summaryrefslogtreecommitdiff
path: root/src/Network/Tox/Relay.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network/Tox/Relay.hs')
-rw-r--r--src/Network/Tox/Relay.hs235
1 files changed, 0 insertions, 235 deletions
diff --git a/src/Network/Tox/Relay.hs b/src/Network/Tox/Relay.hs
deleted file mode 100644
index 2842fcc2..00000000
--- a/src/Network/Tox/Relay.hs
+++ /dev/null
@@ -1,235 +0,0 @@
1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE RecordWildCards #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4module Network.Tox.Relay (tcpRelay) where
5
6import Control.Concurrent.MVar
7import Control.Concurrent.STM
8import Control.Exception
9import Control.Monad
10import qualified Data.ByteString as B
11import Data.Function
12import Data.Functor.Identity
13import qualified Data.IntMap as IntMap
14 ;import Data.IntMap (IntMap)
15import qualified Data.Map as Map
16 ;import Data.Map (Map)
17import Data.Serialize
18import Data.Word
19import Network.Socket (SockAddr)
20import System.IO
21import System.IO.Error
22import System.Timeout
23
24import Crypto.Tox
25import qualified Data.IntervalSet as IntSet
26 ;import Data.IntervalSet (IntSet)
27import Data.Tox.Relay
28import Network.Address (getBindAddress)
29import Network.SocketLike
30import Network.StreamServer
31import Network.Tox.Onion.Transport hiding (encrypt,decrypt)
32
33
34
35hGetPrefixed :: Serialize a => Handle -> IO (Either String a)
36hGetPrefixed h = do
37 mlen <- runGet getWord16be <$> B.hGet h 2
38 -- We treat parse-fail the same as EOF.
39 fmap join $ forM mlen $ \len -> runGet get <$> B.hGet h (fromIntegral len)
40
41hGetSized :: forall x. (Sized x, Serialize x) => Handle -> IO (Either String x)
42hGetSized h = runGet get <$> B.hGet h len -- We treat parse-fail the same as EOF.
43 where
44 ConstSize len = size :: Size x
45
46data RelaySession = RelaySession
47 { indexPool :: IntSet -- ^ Ints that are either solicited or associated.
48 , solicited :: Map PublicKey Int -- ^ Reserved ids, not yet in associated.
49 , associated :: IntMap ((ConId -> RelayPacket) -> IO ()) -- ^ Peers this session is connected to.
50 }
51
52freshSession :: RelaySession
53freshSession = RelaySession
54 { indexPool = IntSet.empty
55 , solicited = Map.empty
56 , associated = IntMap.empty
57 }
58
59disconnect :: TVar (Map PublicKey (RelayPacket -> IO (),TVar RelaySession))
60 -> PublicKey
61 -> IO ()
62disconnect cons who = join $ atomically $ do
63 Map.lookup who <$> readTVar cons
64 >>= \case
65 Nothing -> return $ return ()
66 Just (_,session) -> do
67 modifyTVar' cons $ Map.delete who
68 RelaySession { associated = cs } <- readTVar session
69 return $ let notifyPeer i send = ((send DisconnectNotification) >>)
70 in IntMap.foldrWithKey notifyPeer (return ()) cs
71
72relaySession :: TransportCrypto
73 -> TVar (Map PublicKey (RelayPacket -> IO (),TVar RelaySession))
74 -> (SockAddr -> OnionRequest N1 -> IO ())
75 -> sock
76 -> Int
77 -> Handle
78 -> IO ()
79relaySession crypto cons sendOnion _ conid h = do
80 -- atomically $ modifyTVar' cons $ IntMap.insert conid h
81
82 -- mhello <- fmap (>>= \h -> decryptPayload (computeSharedSecret me (helloFrom h) (helloNonce h)) h) $ hGetSized h
83
84 (hGetSized h >>=) $ mapM_ $ \helloE -> do
85
86 let me = transportSecret crypto
87 them = helloFrom helloE
88
89 noncef <- lookupNonceFunction crypto me them
90 let mhello = decryptPayload (noncef $ helloNonce helloE) helloE
91 forM_ mhello $ \hello -> do
92 let _ = hello :: Hello Identity
93
94 (me',welcome) <- atomically $ do
95 skey <- transportNewKey crypto
96 dta <- HelloData (toPublic skey) <$> transportNewNonce crypto
97 w24 <- transportNewNonce crypto
98 return (skey, Welcome w24 $ pure dta)
99
100 B.hPut h $ encode $ encryptPayload (noncef $ welcomeNonce welcome) welcome
101
102 noncef' <- let them' = sessionPublicKey (runIdentity $ helloData hello)
103 in lookupNonceFunction crypto me' them'
104
105 let readPacket n24 = (>>= decrypt (noncef' n24) >=> decodePlain) <$> hGetPrefixed h
106 base = sessionBaseNonce $ runIdentity $ helloData hello
107
108 -- You get 3 seconds to send a session packet.
109 mpkt0 <- join <$> timeout 3000000 (either (const Nothing) Just <$> readPacket base)
110 forM_ mpkt0 $ \pkt0 -> do
111
112 disconnect cons (helloFrom hello)
113 (sendPacket,session) <- do
114 session <- atomically $ newTVar freshSession
115 sendPacket <- do
116 v <- newMVar (sessionBaseNonce $ runIdentity $ welcomeData welcome)
117 return $ \p -> do
118 case p of
119 DisconnectNotification con -> atomically $ do
120 modifyTVar' session $ \s -> s
121 { indexPool = maybe id IntSet.delete (c2key con) (indexPool s)
122 , associated = maybe id IntMap.delete (c2key con) (associated s)
123 }
124 _ -> return ()
125 n24 <- takeMVar v
126 let bs = encode $ encrypt (noncef' n24) $ encodePlain (p :: RelayPacket)
127 do B.hPut h $ encode (fromIntegral (B.length bs) :: Word16)
128 B.hPut h bs
129 `catchIOError` \_ -> return ()
130 putMVar v (incrementNonce24 n24)
131 atomically $ modifyTVar' cons $ Map.insert (helloFrom hello) (sendPacket,session)
132 return (sendPacket,session)
133
134 handlePacket cons conid (helloFrom hello) crypto sendOnion sendPacket session pkt0
135
136 flip fix (incrementNonce24 base) $ \loop n24 -> do
137 m <- readPacket n24
138 forM_ m $ \p -> do
139 handlePacket cons conid (helloFrom hello) crypto sendOnion sendPacket session p
140 loop (incrementNonce24 n24)
141 `finally`
142 disconnect cons (helloFrom hello)
143
144handlePacket :: TVar (Map PublicKey (RelayPacket -> IO (), TVar RelaySession))
145 -> Int
146 -> PublicKey
147 -> TransportCrypto
148 -> (SockAddr -> OnionRequest N1 -> IO ())
149 -> (RelayPacket -> IO ())
150 -> TVar RelaySession
151 -> RelayPacket
152 -> IO ()
153handlePacket cons thistcp me crypto sendOnion sendToMe session = \case
154 RoutingRequest them -> join $ atomically $ do
155 mySession <- readTVar session
156 mi <- case Map.lookup them (solicited mySession) of
157 Nothing -> fmap join $ forM (IntSet.nearestOutsider 0 (indexPool mySession)) $ \i -> do
158 if -120 <= i && i <= 119
159 then do
160 writeTVar session mySession
161 { indexPool = IntSet.insert i (indexPool mySession)
162 , solicited = Map.insert them i (solicited mySession)
163 }
164 return $ Just i
165 else return Nothing -- No more slots available.
166 Just i -> return $ Just i
167 notifyConnect <- fmap (join . join) $ forM mi $ \i -> do
168 mp <- Map.lookup them <$> readTVar cons
169 forM mp $ \(sendToThem,peer) -> do
170 theirSession <- readTVar peer
171 forM (Map.lookup me $ solicited theirSession) $ \reserved_id -> do
172 let sendToThem' f = sendToThem $ f $ key2c reserved_id
173 sendToMe' f = sendToMe $ f $ key2c i
174 writeTVar peer theirSession
175 { solicited = Map.delete me (solicited theirSession)
176 , associated = IntMap.insert reserved_id sendToMe' (associated theirSession)
177 }
178 writeTVar session mySession
179 { solicited = Map.delete them (solicited mySession)
180 , associated = IntMap.insert i sendToThem' (associated mySession)
181 }
182 return $ do sendToThem' ConnectNotification
183 sendToMe' ConnectNotification
184 return $ do sendToMe $ RoutingResponse (maybe badcon key2c mi) them
185 sequence_ notifyConnect
186
187 RelayPing x -> sendToMe $ RelayPong x -- TODO x==0 is invalid. Do we care?
188
189 OOBSend them bs -> do
190 m <- atomically $ Map.lookup them <$> readTVar cons
191 forM_ m $ \(sendToThem,_) -> sendToThem $ OOBRecv me bs
192
193 RelayData bs con -> join $ atomically $ do
194 -- Data: Data packets can only be sent and received if the
195 -- corresponding connection_id is connection (a Connect notification
196 -- has been received from it) if the server receives a Data packet for
197 -- a non connected or existent connection it will discard it.
198 mySession <- readTVar session
199 return $ sequence_ $ do
200 i <- c2key con
201 sendToThem' <- IntMap.lookup i $ associated mySession
202 return $ sendToThem' $ RelayData bs
203
204 OnionPacket n24 (Addressed addr req) -> do
205 rpath <- atomically $ do
206 sym <- transportSymmetric crypto
207 n <- transportNewNonce crypto
208 return $ wrapSymmetric sym n (TCPIndex thistcp) NoReturnPath
209 sendOnion addr $ OnionRequest n24 req rpath
210
211 _ -> return ()
212
213
214sendTCP_ :: TVar (IntMap (RelayPacket -> IO ())) -> Int -> OnionMessage Encrypted -> IO ()
215sendTCP_ st addr x = join $ atomically
216 $ IntMap.lookup addr <$> readTVar st >>= \case
217 Nothing -> return $ return ()
218 Just send -> return $ send $ OnionPacketResponse x
219
220tcpRelay :: SockAddr -> (SockAddr -> OnionRequest N1 -> IO ()) -> IO (ServerHandle, Int -> OnionMessage Encrypted -> IO ())
221tcpRelay udp_addr sendOnion = do
222 crypto <- newCrypto
223 cons <- newTVarIO Map.empty
224 clients <- newTVarIO IntMap.empty
225 b443 <- getBindAddress "443" True
226 b80 <- getBindAddress "80" True
227 b33445 <- getBindAddress "33445" True
228 bany <- getBindAddress "" True
229 h <- streamServer ServerConfig
230 { serverWarn = hPutStrLn stderr
231 , serverSession = relaySession crypto cons sendOnion
232 }
233 [b443,b80,udp_addr,b33445,bany]
234 return (h,sendTCP_ clients)
235
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-22 17:29:44 +0000