WIP: Standalone TCP relay example program.

1 files changed, 61 insertions, 0 deletions

diff --git a/examples/toxrelay.hs b/examples/toxrelay.hs
new file mode 100644
index 00000000..60c2a44b
--- /dev/null
+++ b/examples/toxrelay.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+import Control.Exception
+import Control.Monad
+import Control.Concurrent.STM
+import qualified Data.ByteString as B
+import Data.Function
+import qualified Data.IntMap as IntMap
+         ;import Data.IntMap (IntMap)
+import Data.Serialize
+import System.IO
+import Data.Functor.Identity
+
+import Crypto.Tox
+import Data.Tox.Relay
+import Network.StreamServer
+import Network.Address (getBindAddress)
+
+
+
+hGetPrefixed :: Serialize a => Handle -> IO (Either String a)
+hGetPrefixed h = do
+    mlen <- runGet getWord16be <$> B.hGet h 2
+    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
+ where
+    ConstSize len = size :: Size x
+
+relaySession :: TVar (IntMap Handle) -> (RelayPacket -> IO ()) -> sock -> Int -> Handle -> IO ()
+relaySession cons dispatch _ conid h = do
+    atomically $ modifyTVar' cons $ IntMap.insert conid h
+    mhello <- fmap (>>= decryptPayload _todo) $ hGetSized h
+    B.hPut h $ encode $ encryptPayload _todo $ Welcome _todo _todo
+    forM_ mhello $ \hello -> do
+        let _ = hello :: Hello Identity
+        fix $ \loop -> do
+            m <- (>>= decrypt _todo >=> decodePlain) <$> hGetPrefixed h
+            forM_ m $ \p -> do
+                dispatch p
+                loop
+     `finally`
+        atomically (modifyTVar' cons $ IntMap.delete conid)
+
+
+
+main :: IO ()
+main = do
+    cons <- newTVarIO IntMap.empty
+    a <- getBindAddress "33445" True
+    h <- streamServer ServerConfig
+                        { serverWarn = hPutStrLn stderr
+                        , serverSession = relaySession cons print
+                        }
+                      a
+
+    putStrLn $ "ENTER to quit..."
+    s <- getLine
+
+    quitListening h