summaryrefslogtreecommitdiff
path: root/src/Network/Tox/TCP.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Network/Tox/TCP.hs')
-rw-r--r--src/Network/Tox/TCP.hs313
1 files changed, 0 insertions, 313 deletions
diff --git a/src/Network/Tox/TCP.hs b/src/Network/Tox/TCP.hs
deleted file mode 100644
index 13da804f..00000000
--- a/src/Network/Tox/TCP.hs
+++ /dev/null
@@ -1,313 +0,0 @@
1{-# LANGUAGE RecursiveDo #-}
2{-# LANGUAGE PartialTypeSignatures #-}
3{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE FlexibleContexts #-}
5module Network.Tox.TCP
6 ( module Network.Tox.TCP
7 , NodeInfo(..)
8 ) where
9
10import Debug.Trace
11import Control.Arrow
12import Control.Concurrent
13import Control.Concurrent.STM
14import Control.Exception
15import Control.Monad
16import Crypto.Random
17import Data.Aeson (ToJSON(..),FromJSON(..))
18import qualified Data.Aeson as JSON
19import Data.Functor.Contravariant
20import Data.Functor.Identity
21import Data.Hashable
22import qualified Data.HashMap.Strict as HashMap
23import Data.IP
24import Data.Maybe
25import Data.Monoid
26import Data.Serialize
27import Data.Word
28import qualified Data.Vector as Vector
29import Network.Socket (SockAddr(..))
30import qualified Text.ParserCombinators.ReadP as RP
31import System.IO.Error
32import System.Timeout
33
34import ControlMaybe
35import Crypto.Tox
36import Data.ByteString (hPut,hGet,ByteString,length)
37import Data.TableMethods
38import Data.Tox.Relay
39import qualified Data.Word64Map
40import DebugTag
41import DPut
42import Network.Address (setPort,PortNumber,localhost4,fromSockAddr)
43import Network.Kademlia.Routing
44import Network.Kademlia.Search hiding (sendQuery)
45import Network.QueryResponse
46import Network.QueryResponse.TCP
47import Network.Tox.DHT.Handlers (toxSpace)
48import Network.Tox.Onion.Transport hiding (encrypt,decrypt)
49import Network.Tox.Onion.Handlers (unwrapAnnounceResponse)
50import qualified Network.Tox.NodeId as UDP
51
52
53withSize :: Sized x => (Size x -> m (p x)) -> m (p x)
54withSize f = case size of len -> f len
55
56
57type NodeId = UDP.NodeId
58
59-- example:
60-- KEyW2Bm.S-DpIGp72380BAfgintUWX1KX.6ZU.4m5Ex@80.99.99.99:33400{tcp:443}
61instance Show NodeInfo where
62 show (NodeInfo udp port) = show udp ++ "{tcp:"++show port++"}"
63
64nodeId :: NodeInfo -> NodeId
65nodeId ni = UDP.nodeId $ udpNodeInfo ni
66
67nodeAddr :: NodeInfo -> SockAddr
68nodeAddr ni = setPort (tcpPort ni) $ UDP.nodeAddr $ udpNodeInfo ni
69
70nodeIP :: NodeInfo -> IP
71nodeIP ni = UDP.nodeIP $ udpNodeInfo ni
72
73tcpStream :: (Show y, Show x, Serialize y, Sized y, Serialize x, Sized x) =>
74 TransportCrypto -> StreamHandshake NodeInfo x y
75tcpStream crypto = StreamHandshake
76 { streamHello = \addr h -> do
77 (skey, hello) <- atomically $ do
78 n24 <- transportNewNonce crypto
79 skey <- transportNewKey crypto
80 base24 <- transportNewNonce crypto
81 return $ (,) skey $ Hello $ Asymm
82 { senderKey = transportPublic crypto
83 , asymmNonce = n24
84 , asymmData = pure HelloData
85 { sessionPublicKey = toPublic $ skey
86 , sessionBaseNonce = base24
87 }
88 }
89 noncef <- lookupNonceFunction crypto (transportSecret crypto) (UDP.id2key $ nodeId addr)
90 dput XTCP $ "TCP:" ++ show addr ++ " <-- " ++ show hello
91 hPut h $ encode $ encryptPayload (noncef $ helloNonce hello) hello
92 welcomeE <- withSize $ fmap decode . hGet h . constSize
93 let mwelcome = welcomeE >>= \w -> decryptPayload (noncef $ welcomeNonce w) w
94 nil = SessionProtocol
95 { streamGoodbye = return ()
96 , streamDecode = return Nothing
97 , streamEncode = \y -> dput XTCP $ "TCP nil <-- " ++ show y
98 }
99 either (\_ -> return nil) id $ mwelcome <&> \welcome -> do
100 dput XTCP $ "TCP:" ++ show addr ++ " --> " ++ show welcome
101 noncef' <- lookupNonceFunction crypto skey (sessionPublicKey $ runIdentity $ welcomeData welcome)
102 nsend <- newMVar (sessionBaseNonce $ runIdentity $ helloData hello)
103 nread <- newMVar (sessionBaseNonce $ runIdentity $ welcomeData welcome)
104 let them = sessionPublicKey $ runIdentity $ welcomeData welcome
105 hvar <- newMVar h
106 return SessionProtocol
107 { streamGoodbye = do
108 dput XTCP $ "Closing " ++ show addr
109 return () -- No goodbye packet? Seems rude.
110 , streamDecode =
111 let go h = decode <$> hGet h 2 >>= \case
112 Left e -> do
113 dput XTCP $ "TCP: (" ++ show addr ++ ") Failed to get length: " ++ e
114 return Nothing
115 Right len -> do
116 decode <$> hGet h (fromIntegral (len :: Word16)) >>= \case
117 Left e -> do
118 dput XTCP $ "TCP: Failed to decode packet."
119 return Nothing
120 Right x -> do
121 m24 <- timeout 1000000 (takeMVar nread)
122 fmap join $ forM m24 $ \n24 -> do
123 let r = decrypt (noncef' n24) x >>= decodePlain
124 putMVar nread (incrementNonce24 n24)
125 either (dput XTCP . ("TCP decryption: " ++))
126 (\x' -> do
127 dput XTCP $ "TCP:" ++ show addr ++ " --> " ++ show x'
128 return ())
129 r
130 return $ either (const Nothing) Just r
131 in bracket (takeMVar hvar) (putMVar hvar)
132 $ \h -> go h `catchIOError` \e -> do
133 dput XTCP $ "TCP exception: " ++ show e
134 return Nothing
135 , streamEncode = \y -> do
136 dput XTCP $ "TCP(acquire nonce):" ++ show addr ++ " <-- " ++ show y
137 n24 <- takeMVar nsend
138 dput XTCP $ "TCP(got nonce):" ++ show addr ++ " <-- " ++ show y
139 let bs = encode $ encrypt (noncef' n24) $ encodePlain y
140 ($ h) -- bracket (takeMVar hvar) (putMVar hvar)
141 $ \h -> hPut h (encode (fromIntegral $ Data.ByteString.length bs :: Word16) <> bs)
142 `catchIOError` \e -> dput XTCP $ "TCP write exception: " ++ show e
143 dput XTCP $ "TCP(incrementing nonce): " ++ show addr ++ " <-- " ++ show y
144 putMVar nsend (incrementNonce24 n24)
145 dput XTCP $ "TCP(finished): " ++ show addr ++ " <-- " ++ show y
146 }
147 , streamAddr = nodeAddr
148 }
149
150toxTCP :: TransportCrypto -> IO ( TCPCache (SessionProtocol RelayPacket RelayPacket)
151 , TransportA err NodeInfo RelayPacket (Bool,RelayPacket) )
152toxTCP crypto = tcpTransport 30 (tcpStream crypto)
153
154tcpSpace :: KademliaSpace NodeId NodeInfo
155tcpSpace = contramap udpNodeInfo toxSpace
156
157{-
158nodeSearch :: TCPClient err () Nonce8 -> Search NodeId (IP, PortNumber) () NodeInfo NodeInfo
159nodeSearch tcp = Search
160 { searchSpace = tcpSpace
161 , searchNodeAddress = nodeIP &&& tcpPort
162 , searchQuery = getNodes tcp
163 }
164-}
165
166data TCPClient err tid = TCPClient
167 { tcpCrypto :: TransportCrypto
168 , tcpClient :: Client err PacketNumber tid NodeInfo (Bool,RelayPacket)
169 , tcpGetGateway :: UDP.NodeInfo -> STM (Maybe NodeInfo)
170 }
171
172{-
173getTCPNodes :: TCPClient err () Nonce8 -> NodeId -> NodeInfo -> IO (Maybe ([NodeInfo],[NodeInfo],Maybe ()))
174getTCPNodes tcp seeking dst = do
175 r <- getUDPNodes' tcp seeking (udpNodeInfo dst)
176 let tcps (ns,_,mb) = (ns',ns',mb)
177 where ns' = do
178 n <- ns
179 [ NodeInfo n (fromIntegral 443) , NodeInfo n (fromIntegral 80) , NodeInfo n (UDP.nodePort n) ]
180 fmap join $ forM r $ \(ns,gw) -> do
181 let ts = tcps ns
182 {-
183 if nodeId gw == nodeId dst
184 then return $ Just ts
185 else do
186 forkIO $ void $ tcpPing (tcpClient tcp) dst
187 return $ Just ts
188 -}
189 forM_ ((\(xs,_,_) -> xs) ts) (forkIO . void . tcpPing (tcpClient tcp))
190 return $ Just ts
191-}
192
193getUDPNodes :: TCPClient err Nonce8 -> NodeId -> UDP.NodeInfo -> IO (Maybe ([UDP.NodeInfo], [UDP.NodeInfo], Maybe ()))
194getUDPNodes tcp seeking dst = fmap fst <$> getUDPNodes' tcp seeking dst
195
196getUDPNodes' :: TCPClient err Nonce8 -> NodeId -> UDP.NodeInfo -> IO (Maybe (([UDP.NodeInfo], [UDP.NodeInfo], Maybe ()), NodeInfo))
197getUDPNodes' tcp seeking dst0 = do
198 mgateway <- atomically $ tcpGetGateway tcp dst0
199 fmap join $ forM mgateway $ \gateway -> do
200 (b,c,n24) <- atomically $ do
201 b <- transportNewKey (tcpCrypto tcp)
202 c <- transportNewKey (tcpCrypto tcp)
203 n24 <- transportNewNonce (tcpCrypto tcp)
204 return (b,c,n24)
205 let (dst,gateway') = if UDP.nodeId dst0 == nodeId gateway
206 then ( dst0 { UDP.nodeIP = fromJust $ Network.Address.fromSockAddr localhost4 }
207 , gateway { udpNodeInfo = (udpNodeInfo gateway)
208 { UDP.nodeIP = fromJust $ Network.Address.fromSockAddr localhost4 }})
209 else (dst0,gateway)
210 wrap2 <- lookupNonceFunction (tcpCrypto tcp) b (UDP.id2key $ UDP.nodeId dst)
211 wrap1 <- lookupNonceFunction (tcpCrypto tcp) c (UDP.id2key $ nodeId gateway)
212 wrap0 <- lookupNonceFunction (tcpCrypto tcp) (transportSecret $ tcpCrypto tcp) (UDP.id2key $ UDP.nodeId dst)
213 let meth :: MethodSerializer
214 Nonce8
215 a -- NodeInfo
216 (Bool, RelayPacket)
217 PacketNumber
218 AnnounceRequest
219 (Either String AnnounceResponse)
220 meth = MethodSerializer
221 { methodTimeout = \tid addr -> return (addr,12000000) -- 12 second timeout
222 , method = OnionPacketID -- meth
223 , wrapQuery = \n8 src gateway x -> (,) True $
224 OnionPacket n24 $ Addressed (UDP.nodeAddr dst)
225 $ wrapOnionPure b (wrap2 n24) (nodeAddr gateway')
226 $ wrapOnionPure c (wrap1 n24) (UDP.nodeAddr dst)
227 $ NotForwarded $ encryptPayload (wrap0 n24)
228 $ OnionAnnounce Asymm
229 { senderKey = transportPublic (tcpCrypto tcp)
230 , asymmNonce = n24
231 , asymmData = pure (x,n8)
232 }
233 , unwrapResponse = \case
234 (_,OnionPacketResponse (OnionAnnounceResponse _ n24' r))
235 -> decrypt (wrap0 n24') r >>= decodePlain
236 x -> Left $ "getUDPNodes: unwrapResponse fail " ++ show x
237 }
238 r <- sendQuery (tcpClient tcp) meth (AnnounceRequest zeros32 seeking UDP.zeroID) gateway
239 forM r $ \response -> do
240 let (ns,_,mb) = either (const ([],[],Nothing)) (unwrapAnnounceResponse Nothing dst) $ response
241 return ( (ns,ns, const () <$> mb), gateway )
242
243
244handleOOB :: PublicKey -> ByteString -> NodeInfo -> NodeInfo -> IO (Maybe (x -> x))
245handleOOB k bs src dst = do
246 dput XMisc $ "TODO: handleOOB " ++ show src
247 return Nothing
248
249handle2route :: OnionMessage Encrypted -> NodeInfo -> NodeInfo -> IO (Maybe (x -> x))
250handle2route o src dst = do
251 dput XMisc $ "TODO: handle2route " ++ show src
252 return Nothing
253
254tcpPing :: Show addr => Client err PacketNumber Nonce8 addr (Bool,RelayPacket) -> addr -> IO (Maybe ())
255tcpPing client dst = do
256 dput XTCP $ "tcpPing " ++ show dst
257 sendQuery client meth () dst
258 where meth = MethodSerializer
259 { wrapQuery = \n8 src dst () -> (True,RelayPing n8)
260 , unwrapResponse = \_ -> ()
261 , methodTimeout = \n8 dst -> return (dst,5000000)
262 , method = PingPacket
263 }
264
265type RelayClient = Client String PacketNumber Nonce8 NodeInfo (Bool,RelayPacket)
266
267-- | Create a new TCP relay client. Because polymorphic existential record
268-- updates are currently hard with GHC, this function accepts parameters for
269-- generalizing the table-entry type for pending transactions. Safe trivial
270-- defaults are 'id' and 'tryPutMVar'. The resulting customized table state
271-- will be returned to the caller along with the new client.
272newClient :: TransportCrypto
273 -> ((Maybe (Bool,RelayPacket) -> IO ()) -> a) -- ^ store mvar for query
274 -> (a -> RelayPacket -> IO void) -- ^ load mvar for query
275 -> IO ( ( TVar (ChaChaDRG, Data.Word64Map.Word64Map a)
276 , TCPCache (SessionProtocol RelayPacket RelayPacket) )
277 , Client String PacketNumber Nonce8 NodeInfo (Bool,RelayPacket))
278newClient crypto store load = do
279 (tcpcache,net) <- toxTCP crypto
280 drg <- drgNew
281 map_var <- atomically $ newTVar (drg, Data.Word64Map.empty)
282 return $ (,) (map_var,tcpcache) Client
283 { clientNet = {- XXX: Client type forces this pointless layering. -} layerTransport ((Right .) . (,) . (,) False) (,) net
284 , clientDispatcher = DispatchMethods
285 { classifyInbound = (. snd) $ \case
286 RelayPing n -> IsQuery PingPacket n
287 RelayPong n -> IsResponse n
288 OnionPacketResponse (OnionAnnounceResponse n8 n24 ciphered) -> IsResponse n8
289 OnionPacketResponse o@(OnionToRouteResponse _) -> IsUnsolicited $ handle2route o
290 OOBRecv k bs -> IsUnsolicited $ handleOOB k bs
291 wut -> IsUnknown (show wut)
292 , lookupHandler = \case
293 PingPacket -> trace ("tcp-received-ping") $ Just MethodHandler
294 { methodParse = \case (_,RelayPing n8) -> Right ()
295 _ -> trace ("tcp-non-ping") $ Left "TCP: Non-ping?"
296 , methodSerialize = \n8 src dst () -> trace ("tcp-made-pong-"++show n8) (False, RelayPong n8)
297 , methodAction = \src () -> dput XTCP $ "TCP pinged by "++show src
298 }
299 w -> trace ("tcp-lookupHandler: "++show w) $ Just NoReply
300 { methodParse = \x -> Left "tcp-lookuphandler?" -- :: x -> Either err a
301 , noreplyAction = \addr a -> dput XTCP $ "tcp-lookupHandler: "++show w
302 }
303 , tableMethods = transactionMethods' store (\x -> mapM_ (load x . snd)) (contramap (\(Nonce8 w64) -> w64) w64MapMethods)
304 $ first (either error Nonce8 . decode) . randomBytesGenerate 8
305 }
306 , clientErrorReporter = logErrors
307 , clientPending = map_var
308 , clientAddress = \_ -> return $ NodeInfo
309 { udpNodeInfo = either error id $ UDP.nodeInfo (UDP.key2id $ transportPublic crypto) (SockAddrInet 0 0)
310 , tcpPort = 0
311 }
312 , clientResponseId = return
313 }
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-11 17:27:08 +0000