blob: fdf0c011cfc17ba8060c0338dd8e7c1c967a38c9 (
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
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
|
{-# 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)
import Network.Tox (newCrypto)
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 :: TransportCrypto -> TVar (IntMap Handle) -> (RelayPacket -> IO ()) -> sock -> Int -> Handle -> IO ()
relaySession crypto cons dispatch _ 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
(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
let them' = sessionPublicKey (runIdentity $ helloData hello)
noncef' <- lookupNonceFunction crypto me' them'
let _ = hello :: Hello Identity
flip fix (sessionBaseNonce $ runIdentity $ helloData hello) $ \loop n24 -> do
m <- (>>= decrypt (noncef' n24) >=> decodePlain) <$> hGetPrefixed h
forM_ m $ \p -> do
dispatch p
loop (incrementNonce24 n24)
`finally`
atomically (modifyTVar' cons $ IntMap.delete conid)
main :: IO ()
main = do
crypto <- newCrypto
cons <- newTVarIO IntMap.empty
a <- getBindAddress "33445" True
h <- streamServer ServerConfig
{ serverWarn = hPutStrLn stderr
, serverSession = relaySession crypto cons print
}
a
putStrLn $ "ENTER to quit..."
s <- getLine
quitListening h
|
