blob: 60c2a44b4e30bf95b1bd872cd671f7aebb33e531 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
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
|
