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
83
84
85
|
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
module Network.Tox.TCP where
import Control.Concurrent
import Control.Concurrent.STM
import Data.Functor.Identity
import Data.Serialize
import System.IO (Handle)
import Crypto.Tox
import Data.ByteString (hPut,hGet,ByteString)
import Data.Tox.Relay
import Network.Address (setPort,PortNumber,SockAddr)
import Network.QueryResponse
import Network.QueryResponse.TCP
import qualified Network.Tox.NodeId as UDP
withSize :: Sized x => (Size x -> m (p x)) -> m (p x)
withSize f = case size of len -> f len
data NodeInfo = NodeInfo
{ udpNodeInfo :: UDP.NodeInfo
, tcpPort :: PortNumber
}
type NodeId = UDP.NodeId
nodeId :: NodeInfo -> NodeId
nodeId ni = UDP.nodeId $ udpNodeInfo ni
nodeAddr :: NodeInfo -> SockAddr
nodeAddr ni = setPort (tcpPort ni) $ UDP.nodeAddr $ udpNodeInfo ni
tcpStream :: (Serialize y, Sized y, Serialize x, Sized x) =>
TransportCrypto -> StreamHandshake NodeInfo x y
tcpStream crypto = StreamHandshake
{ streamHello = \addr h -> do
(skey, hello) <- atomically $ do
n24 <- transportNewNonce crypto
skey <- transportNewKey crypto
base24 <- transportNewNonce crypto
return $ (,) skey $ Hello $ Asymm
{ senderKey = transportPublic crypto
, asymmNonce = n24
, asymmData = pure HelloData
{ sessionPublicKey = toPublic $ skey
, sessionBaseNonce = base24
}
}
noncef <- lookupNonceFunction crypto (transportSecret crypto) (UDP.id2key $ nodeId addr)
hPut h $ encode $ encryptPayload (noncef $ helloNonce hello) hello
welcomeE <- withSize $ fmap decode . hGet h . constSize
let Right welcome = welcomeE >>= \w -> decryptPayload (noncef $ welcomeNonce w) w
noncef' <- lookupNonceFunction crypto skey (sessionPublicKey $ runIdentity $ welcomeData welcome)
nsend <- newMVar (sessionBaseNonce $ runIdentity $ helloData hello)
nread <- newMVar (sessionBaseNonce $ runIdentity $ welcomeData welcome)
let them = sessionPublicKey $ runIdentity $ welcomeData welcome
return SessionProtocol
{ streamGoodbye = \h -> return () -- No goodbye packet? Seems rude.
, streamDecode = \h -> do
decode <$> hGet h 2 >>= \case
Left _ -> return Nothing
Right len -> do
decode <$> hGet h len >>= \case
Left _ -> return Nothing
Right x -> do
n24 <- takeMVar nread
let r = decrypt (noncef' n24) x >>= decodePlain
putMVar nread (incrementNonce24 n24)
return $ either (const Nothing) Just r
, streamEncode = \y -> do
n24 <- takeMVar nsend
let bs = encode $ encrypt (noncef' n24) $ encodePlain y
putMVar nsend (incrementNonce24 n24)
return bs -- XXX: Should we wait until this bytestring is sent before putting the nonce back in the MVar?
}
, streamAddr = nodeAddr
}
toxTCP :: TransportCrypto -> IO (Transport err NodeInfo RelayPacket)
toxTCP crypto = tcpTransport 30 (tcpStream crypto)
|
