From d4c209fb9543019461bcf612da67708aeabcdce2 Mon Sep 17 00:00:00 2001
From: Joe Crayne <joe@jerkface.net>
Date: Sat, 25 Jan 2020 01:02:33 -0500
Subject: Ported dhtd to reworked QueryResponse design.

---
 dht/src/Network/Tox/TCP.hs | 34 ++++++++++++++++++----------------
 1 file changed, 18 insertions(+), 16 deletions(-)

(limited to 'dht/src/Network/Tox/TCP.hs')

diff --git a/dht/src/Network/Tox/TCP.hs b/dht/src/Network/Tox/TCP.hs
index 1da302b6..626d4714 100644
--- a/dht/src/Network/Tox/TCP.hs
+++ b/dht/src/Network/Tox/TCP.hs
@@ -160,22 +160,22 @@ tcpStream crypto mkst = StreamHandshake
     , streamAddr = nodeAddr
     }
 
-newtype SessionData = SessionData (MVar (IntMap.IntMap NodeId))
+newtype SessionData = SessionData (TMVar (IntMap.IntMap NodeId))
 
 newSessionData :: NodeInfo -> IO SessionData
-newSessionData _ = SessionData <$> newMVar IntMap.empty
+newSessionData _ = atomically $ SessionData <$> newTMVar IntMap.empty
 
-getRelayedRemote :: SessionData -> ConId -> IO NodeId
+getRelayedRemote :: SessionData -> ConId -> STM NodeId
 getRelayedRemote (SessionData keymapVar) (ConId i) = do
-    keymap <- takeMVar keymapVar
+    keymap <- takeTMVar keymapVar
     let k = fromMaybe UDP.zeroID $ IntMap.lookup (fromIntegral i) keymap
-    putMVar keymapVar keymap
+    putTMVar keymapVar keymap
     return k
 
-setRelayedRemote :: SessionData -> ConId -> NodeId -> IO ()
+setRelayedRemote :: SessionData -> ConId -> NodeId -> STM ()
 setRelayedRemote (SessionData keymapVar) (ConId conid) nid = do
-    keymap <- takeMVar keymapVar
-    putMVar keymapVar $ IntMap.insert (fromIntegral conid) nid keymap
+    keymap <- takeTMVar keymapVar
+    putTMVar keymapVar $ IntMap.insert (fromIntegral conid) nid keymap
 
 toxTCP :: TransportCrypto -> IO ( TCPCache (SessionProtocol (SessionData,RelayPacket) RelayPacket)
                                 , TransportA err NodeInfo (SessionData,RelayPacket) (Bool,RelayPacket) )
@@ -367,7 +367,7 @@ type RelayCache = TCPCache (SessionProtocol (SessionData,RelayPacket) RelayPacke
 newClient :: TransportCrypto
                -> ((Nonce8 -> QR.Result (Bool,RelayPacket) -> IO ()) -> a)      -- ^ store mvar for relay query
                -> (a -> Nonce8 -> RelayPacket -> IO void)                       -- ^ load mvar for relay query
-               -> (SockAddr -> Nonce8 -> IO (Maybe (OnionDestination RouteId))) -- ^ lookup sender of onion query
+               -> (SockAddr -> Nonce8 -> STM (Maybe (OnionDestination RouteId))) -- ^ lookup sender of onion query
                -> (UDP.NodeInfo -> RouteId -> IO (Maybe OnionRoute))            -- ^ lookup OnionRoute by id
                -> IO ( ( TVar (ChaChaDRG, Data.Word64Map.Word64Map a)
                        , RelayCache
@@ -375,8 +375,9 @@ newClient :: TransportCrypto
                        , Transport String (OnionDestination RouteId) (OnionMessage Encrypted) )
                      , RelayClient )
 newClient crypto store load lookupSender getRoute = do
+    let runio io = return () -- TODO: run IO action
     (tcpcache,net0) <- toxTCP crypto
-    (relaynet,net1) <- partitionRelay net0
+    (relaynet,net1) <- partitionRelay runio net0
     (onionnet,net2) <- partitionOnion crypto lookupSender getRoute net1
     let net3 = {- XXX: Client type forces this pointless layering. -}
                layerTransport ((Right .) . (,) . (,) False . snd) (,) net2
@@ -428,12 +429,13 @@ showViaRelay (ViaRelay mcon nid tcp) =
     "TCP:" ++ maybe "(oob)" (\(ConId con) -> "(" ++ show con ++ ")") mcon
            ++ show nid ++ "@@" ++ show (nodeAddr tcp)
 
-partitionRelay :: TransportA err NodeInfo (SessionData,RelayPacket) (Bool,RelayPacket)
+partitionRelay :: (IO () -> STM ())
+                      -> TransportA err NodeInfo (SessionData,RelayPacket) (Bool,RelayPacket)
                       -> IO ( Transport err ViaRelay ByteString
                             , TransportA err NodeInfo (SessionData,RelayPacket) (Bool,RelayPacket))
-partitionRelay tr = partitionTransportM parse encode tr
+partitionRelay runio tr = partitionTransportM parse encode tr
   where
-    parse :: ((SessionData,RelayPacket), NodeInfo) -> IO (Either (ByteString, ViaRelay) ((SessionData,RelayPacket),NodeInfo))
+    parse :: ((SessionData,RelayPacket), NodeInfo) -> STM (Either (ByteString, ViaRelay) ((SessionData,RelayPacket),NodeInfo))
     parse ((st,RelayData bs conid), ni) = do
         nid <- getRelayedRemote st conid
         return $ Left (bs, ViaRelay (Just conid) nid ni)
@@ -463,7 +465,7 @@ partitionRelay tr = partitionTransportM parse encode tr
 
 
 partitionOnion :: TransportCrypto
-                  -> (SockAddr -> Nonce8 -> IO (Maybe (OnionDestination RouteId)))
+                  -> (SockAddr -> Nonce8 -> STM (Maybe (OnionDestination RouteId)))
                   -> (UDP.NodeInfo -> RouteId -> IO (Maybe OnionRoute))
                   -> TransportA err NodeInfo (SessionData,RelayPacket) (Bool,RelayPacket)
                   -> IO ( Transport err (OnionDestination RouteId) (OnionMessage Encrypted)
@@ -471,8 +473,8 @@ partitionOnion :: TransportCrypto
 partitionOnion crypto lookupSender getRoute tr = partitionTransportM parse encode tr
  where
     parse :: ((SessionData,RelayPacket), NodeInfo)
-                -> IO (Either (OnionMessage Encrypted   , OnionDestination RouteId)
-                              ((SessionData,RelayPacket), NodeInfo))
+                -> STM (Either (OnionMessage Encrypted   , OnionDestination RouteId)
+                               ((SessionData,RelayPacket), NodeInfo))
     parse pass@((_,OnionPacketResponse msg@(OnionAnnounceResponse n8 _ _)), nodeA) = do
         m <- lookupSender (nodeAddr nodeA) n8
         case m of
-- 
cgit v1.2.3