wip, tcp

hbs2-core/lib/HBS2/Net/Messaging/TCP.hs

@@ -9,6 +9,7 @@ module HBS2.Net.Messaging.TCP
   , tcpPeerConn
   , tcpCookie
   , tcpOnClientStarted
+  , tcpPeerKick
   , messagingTCPSetProbe
   ) where
 
@@ -205,6 +206,13 @@ data TCPMessagingError =
 
 instance Exception TCPMessagingError
 
+tcpPeerKick :: forall m . MonadIO m => MessagingTCP -> Peer L4Proto -> m ()
+tcpPeerKick MessagingTCP{..} p = do
+  whoever <- readTVarIO _tcpPeerSocket <&> HM.lookup p
+  for_ whoever $ \so -> do
+    debug $ "tcpPeerKick" <+> pretty p
+    liftIO $ shutdown so ShutdownBoth
+
 runMessagingTCP :: forall m . MonadIO m => MessagingTCP -> m ()
 runMessagingTCP env@MessagingTCP{..} = liftIO do
 

hbs2-peer/app/PeerMain.hs

@@ -1321,6 +1321,7 @@ runPeer opts = respawnOnError opts $ do
 
   let rpcctx = RPC2Context { rpcConfig = fromPeerConfig conf
                            , rpcMessaging = rpcmsg
+                           , rpcTCP = tcp
                            , rpcPokeAnswer = pokeAnsw
                            , rpcPeerEnv = penv
                            , rpcLocalMultiCast = localMulticast

hbs2-peer/app/RPC2.hs

@@ -24,6 +24,8 @@ import HBS2.Net.Auth.Schema
 import HBS2.Peer.RPC.Internal.Types
 import HBS2.Peer.RPC.API.Peer
 
+import HBS2.Net.Messaging.TCP
+
 import Data.Config.Suckless.Script
 
 import RPC2.Peer
@@ -35,12 +37,13 @@ import RPC2.Mailbox()
 import PeerTypes
 import PeerInfo
 
-import UnliftIO
-
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Cont
 import Data.Text qualified as Text
 import Data.Either
 import Data.Maybe
 import Numeric
+import UnliftIO
 
 instance (e ~ L4Proto, MonadUnliftIO m, HasRpcContext PeerAPI RPC2Context m) => HandleMethod m RpcRunScript where
   handleMethod top = do
@@ -59,6 +62,29 @@ instance (e ~ L4Proto, MonadUnliftIO m, HasRpcContext PeerAPI RPC2Context m) =>
         entry $ bindMatch "hey" $ const do
           pure $ mkSym @C "hey"
 
+        entry $ bindMatch "tcp:peer:kick" $ \case
+          [ StringLike addr ] -> flip runContT pure $ callCC \exit -> do
+
+            peer' <- liftIO $ try @_ @SomeException do
+                      let pa = fromString @(PeerAddr L4Proto) addr
+                      fromPeerAddr pa
+
+            peer <- either (const $ exit (mkSym "error:invalid-address")) pure peer'
+
+            mess <- ContT $ maybe1 rpcTCP (pure nil)
+
+            tcpPeerKick mess peer
+
+            liftIO $ withPeerM rpcPeerEnv do
+              pl <- getPeerLocator @e
+              delPeers pl [peer]
+              expire (PeerInfoKey peer)
+              expire (KnownPeerKey peer)
+
+            pure $ mkList [mkSym "kicked", mkSym (show $ pretty peer) ]
+
+          _ -> pure nil
+
         entry $ bindMatch "peer-info" $ const do
 
           now <- getTimeCoarse

hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs

@@ -12,6 +12,7 @@ import HBS2.Storage()
 import HBS2.Data.Types.Refs (HashRef)
 import HBS2.Data.Types.SignedBox
 import HBS2.Net.Messaging.Unix
+import HBS2.Net.Messaging.TCP
 import HBS2.Net.Messaging.Encrypted.ByPass (ByPassStat)
 import HBS2.Net.Proto.Service
 import HBS2.Peer.Proto.Mailbox
@@ -32,6 +33,7 @@ data RPC2Context =
   RPC2Context
   { rpcConfig              :: [Syntax C]
   , rpcMessaging           :: MessagingUnix
+  , rpcTCP                 :: Maybe MessagingTCP
   , rpcPokeAnswer          :: String
   , rpcPeerEnv             :: PeerEnv L4Proto
   , rpcLocalMultiCast      :: Peer L4Proto