From d0f1ce6171ccb59fce7534a19e827352b35686a0 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sun, 26 May 2024 14:04:09 +0200
Subject: Manual peer drop

---
 src/Erebos/Network/Protocol.hs | 12 ++++++++++++
 1 file changed, 12 insertions(+)

(limited to 'src/Erebos/Network/Protocol.hs')

diff --git a/src/Erebos/Network/Protocol.hs b/src/Erebos/Network/Protocol.hs
index a669988..26bd615 100644
--- a/src/Erebos/Network/Protocol.hs
+++ b/src/Erebos/Network/Protocol.hs
@@ -20,6 +20,7 @@ module Erebos.Network.Protocol (
     connData,
     connGetChannel,
     connSetChannel,
+    connClose,
 
     RawStreamReader, RawStreamWriter,
     connAddWriteStream,
@@ -44,6 +45,7 @@ import Data.ByteString (ByteString)
 import Data.ByteString qualified as B
 import Data.ByteString.Char8 qualified as BC
 import Data.ByteString.Lazy qualified as BL
+import Data.Function
 import Data.List
 import Data.Maybe
 import Data.Text (Text)
@@ -184,6 +186,9 @@ data Connection addr = Connection
     , cOutStreams :: TVar [(Word8, Stream)]
     }
 
+instance Eq (Connection addr) where
+    (==) = (==) `on` cChannel
+
 connAddress :: Connection addr -> addr
 connAddress = cAddress
 
@@ -197,6 +202,12 @@ connSetChannel :: Connection addr -> ChannelState -> STM ()
 connSetChannel Connection {..} ch = do
     writeTVar cChannel ch
 
+connClose :: Connection addr -> STM ()
+connClose conn@Connection {..} = do
+    let GlobalState {..} = cGlobalState
+    writeTVar cChannel ChannelClosed
+    writeTVar gConnections . filter (/=conn) =<< readTVar gConnections
+
 connAddWriteStream :: Connection addr -> STM (Either String (TransportHeaderItem, RawStreamWriter, IO ()))
 connAddWriteStream conn@Connection {..} = do
     outStreams <- readTVar cOutStreams
@@ -380,6 +391,7 @@ data ChannelState = ChannelNone
                   | ChannelPeerRequest WaitingRef
                   | ChannelOurAccept (Stored ChannelAccept) Channel
                   | ChannelEstablished Channel
+                  | ChannelClosed
 
 data ReservedToSend = ReservedToSend
     { rsAckedBy :: Maybe (TransportHeaderItem -> Bool)
-- 
cgit v1.2.3