1 files changed, 235 insertions, 0 deletions
diff --git a/src/Network/Tox/Relay.hs b/src/Network/Tox/Relay.hs
new file mode 100644
index 00000000..17bbc379
--- /dev/null
+++ b/src/Network/Tox/Relay.hs
@@ -0,0 +1,235 @@
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Network.Tox.Relay (tcpRelay) where
+import Control.Concurrent.MVar
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad
+import qualified Data.ByteString as B
+import Data.Function
+import Data.Functor.Identity
+import qualified Data.IntMap     as IntMap
+         ;import Data.IntMap     (IntMap)
+import qualified Data.Map        as Map
+         ;import Data.Map        (Map)
+import Data.Serialize
+import Data.Word
+import Network.Socket (SockAddr)
+import System.IO
+import System.IO.Error
+import System.Timeout
+import Crypto.Tox
+import qualified Data.IntervalSet as IntSet
+         ;import Data.IntervalSet (IntSet)
+import Data.Tox.Relay
+import Network.Address (getBindAddress)
+import Network.SocketLike
+import Network.StreamServer
+import Network.Tox (newCrypto)
+import Network.Tox.Onion.Transport hiding (encrypt,decrypt)
+hGetPrefixed :: Serialize a => Handle -> IO (Either String a)
+hGetPrefixed h = do
+    mlen <- runGet getWord16be <$> B.hGet h 2
+    -- We treat parse-fail the same as EOF.
+    fmap join $ forM mlen $ \len -> runGet get <$> B.hGet h (fromIntegral len)
+hGetSized :: forall x. (Sized x, Serialize x) => Handle -> IO (Either String x)
+hGetSized h = runGet get <$> B.hGet h len -- We treat parse-fail the same as EOF.
+ where
+    ConstSize len = size :: Size x
+data RelaySession = RelaySession
+    { indexPool  :: IntSet                                   -- ^ Ints that are either solicited or associated.
+    , solicited  :: Map PublicKey Int                        -- ^ Reserved ids, not yet in associated.
+    , associated :: IntMap ((ConId -> RelayPacket) -> IO ()) -- ^ Peers this session is connected to.
+    }
+freshSession :: RelaySession
+freshSession = RelaySession
+    { indexPool  = IntSet.empty
+    , solicited  = Map.empty
+    , associated = IntMap.empty
+    }
+disconnect :: TVar (Map PublicKey (RelayPacket -> IO (),TVar RelaySession))
+                -> PublicKey
+                -> IO ()
+disconnect cons who = join $ atomically $ do
+    Map.lookup who <$> readTVar cons
+        >>= \case
+        Nothing -> return $ return ()
+        Just (_,session) -> do
+            modifyTVar' cons $ Map.delete who
+            RelaySession { associated = cs } <- readTVar session
+            return $ let notifyPeer i send = ((send DisconnectNotification) >>)
+                     in IntMap.foldrWithKey notifyPeer (return ()) cs
+relaySession :: TransportCrypto
+                -> TVar (Map PublicKey (RelayPacket -> IO (),TVar RelaySession))
+                -> (SockAddr -> OnionRequest N1 -> IO ())
+                -> sock
+                -> Int
+                -> Handle
+                -> IO ()
+relaySession crypto cons sendOnion _ conid h = do
+    -- atomically $ modifyTVar' cons $ IntMap.insert conid h
+    -- mhello <- fmap (>>= \h -> decryptPayload (computeSharedSecret me (helloFrom h) (helloNonce h)) h) $ hGetSized h
+    (hGetSized h >>=) $ mapM_ $ \helloE -> do
+    let me = transportSecret crypto
+        them = helloFrom helloE
+    noncef <- lookupNonceFunction crypto me them
+    let mhello = decryptPayload (noncef $ helloNonce helloE) helloE
+    forM_ mhello $ \hello -> do
+        let _ = hello :: Hello Identity
+        (me',welcome) <- atomically $ do
+            skey <- transportNewKey crypto
+            dta <- HelloData (toPublic skey) <$> transportNewNonce crypto
+            w24 <- transportNewNonce crypto
+            return (skey, Welcome w24 $ pure dta)
+        B.hPut h $ encode $ encryptPayload (noncef $ welcomeNonce welcome) welcome
+        noncef' <- let them' = sessionPublicKey (runIdentity $ helloData hello)
+                   in lookupNonceFunction crypto me' them'
+        let readPacket n24 = (>>= decrypt (noncef' n24) >=> decodePlain) <$> hGetPrefixed h
+            base = sessionBaseNonce $ runIdentity $ helloData hello
+        -- You get 3 seconds to send a session packet.
+        mpkt0 <- join <$> timeout 3000000 (either (const Nothing) Just <$> readPacket base)
+        forM_ mpkt0 $ \pkt0 -> do
+            disconnect cons (helloFrom hello)
+            (sendPacket,session) <- do
+                session <- atomically $ newTVar freshSession
+                sendPacket <- do
+                    v <- newMVar (sessionBaseNonce $ runIdentity $ welcomeData welcome)
+                    return $ \p -> do
+                        case p of
+                            DisconnectNotification con -> atomically $ do
+                                modifyTVar' session $ \s -> s
+                                    { indexPool = maybe id IntSet.delete (c2key con) (indexPool s)
+                                    , associated = maybe id IntMap.delete (c2key con) (associated s)
+                                    }
+                            _ -> return ()
+                        n24 <- takeMVar v
+                        let bs = encode $ encrypt (noncef' n24) $ encodePlain (p :: RelayPacket)
+                        do B.hPut h $ encode (fromIntegral (B.length bs) :: Word16)
+                           B.hPut h bs
+                         `catchIOError` \_ -> return ()
+                        putMVar v (incrementNonce24 n24)
+                atomically $ modifyTVar' cons $ Map.insert (helloFrom hello) (sendPacket,session)
+                return (sendPacket,session)
+            handlePacket cons conid (helloFrom hello) crypto sendOnion sendPacket session pkt0
+            flip fix (incrementNonce24 base)  $ \loop n24 -> do
+                m <- readPacket n24
+                forM_ m $ \p -> do
+                    handlePacket cons conid (helloFrom hello) crypto sendOnion sendPacket session p
+                    loop (incrementNonce24 n24)
+         `finally`
+            disconnect cons (helloFrom hello)
+handlePacket :: TVar (Map PublicKey (RelayPacket -> IO (), TVar RelaySession))
+                      -> Int
+                      -> PublicKey
+                      -> TransportCrypto
+                      -> (SockAddr -> OnionRequest N1 -> IO ())
+                      -> (RelayPacket -> IO ())
+                      -> TVar RelaySession
+                      -> RelayPacket
+                      -> IO ()
+handlePacket cons thistcp me crypto sendOnion sendToMe session = \case
+    RoutingRequest them -> join $ atomically $ do
+        mySession <- readTVar session
+        mi <- case Map.lookup them (solicited mySession) of
+            Nothing -> fmap join $ forM (IntSet.nearestOutsider 0 (indexPool mySession)) $ \i -> do
+                if -120 <= i && i <= 119
+                    then do
+                        writeTVar session mySession
+                            { indexPool = IntSet.insert i (indexPool mySession)
+                            , solicited = Map.insert them i (solicited mySession)
+                            }
+                        return $ Just i
+                    else return Nothing -- No more slots available.
+            Just i  -> return $ Just i
+        notifyConnect <- fmap (join . join) $ forM mi $ \i -> do
+            mp <- Map.lookup them <$> readTVar cons
+            forM mp $ \(sendToThem,peer) -> do
+                theirSession <- readTVar peer
+                forM (Map.lookup me $ solicited theirSession) $ \reserved_id -> do
+                    let sendToThem' f = sendToThem $ f $ key2c reserved_id
+                        sendToMe'   f = sendToMe   $ f $ key2c i
+                    writeTVar peer theirSession
+                        { solicited  = Map.delete me (solicited theirSession)
+                        , associated = IntMap.insert reserved_id sendToMe' (associated theirSession)
+                        }
+                    writeTVar session mySession
+                        { solicited  = Map.delete them (solicited mySession)
+                        , associated = IntMap.insert i sendToThem' (associated mySession)
+                        }
+                    return $ do sendToThem' ConnectNotification
+                                sendToMe'   ConnectNotification
+        return $ do sendToMe $ RoutingResponse (maybe badcon key2c mi) them
+                    sequence_ notifyConnect
+    RelayPing x -> sendToMe $ RelayPong x -- TODO x==0 is invalid.  Do we care?
+    OOBSend them bs -> do
+        m <- atomically $ Map.lookup them <$> readTVar cons
+        forM_ m $ \(sendToThem,_) -> sendToThem $ OOBRecv me bs
+    RelayData bs con -> join $ atomically $ do
+        -- Data: Data packets can only be sent and received if the
+        -- corresponding connection_id is connection (a Connect notification
+        -- has been received from it) if the server receives a Data packet for
+        -- a non connected or existent connection it will discard it.
+        mySession <- readTVar session
+        return $ sequence_ $ do
+            i <- c2key con
+            sendToThem' <- IntMap.lookup i $ associated mySession
+            return $ sendToThem' $ RelayData bs
+    OnionPacket p -> do
+        mp <- rewrap crypto (TCPIndex thistcp) p
+        case mp of
+            Right (p',addr) -> sendOnion addr p'
+            _               -> return ()
+    _ -> return ()
+sendTCP_ :: TVar (IntMap (RelayPacket -> IO ())) -> Int -> OnionResponse N1 -> IO ()
+sendTCP_ st addr x = join $ atomically
+    $ IntMap.lookup addr <$> readTVar st >>= \case
+        Nothing   -> return $ return ()
+        Just send -> return $ send $ OnionPacketResponse x
+tcpRelay :: SockAddr -> (SockAddr -> OnionRequest N1 -> IO ()) -> IO (ServerHandle, Int -> OnionResponse N1 -> IO ())
+tcpRelay udp_addr sendOnion = do
+    crypto <- newCrypto
+    cons <- newTVarIO Map.empty
+    clients <- newTVarIO IntMap.empty
+    b443   <- getBindAddress "443"   True
+    b80    <- getBindAddress "80"    True
+    b33445 <- getBindAddress "33445" True
+    bany   <- getBindAddress ""      True
+    h <- streamServer ServerConfig
+                        { serverWarn    = hPutStrLn stderr
+                        , serverSession = relaySession crypto cons sendOnion
+                        }
+                      [b443,b80,udp_addr,b33445,bany]
+    return (h,sendTCP_ clients)

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