diff --git a/hbs2-core/lib/HBS2/Net/Messaging/TCP.hs b/hbs2-core/lib/HBS2/Net/Messaging/TCP.hs index b14943b3..4a0d3a0b 100644 --- a/hbs2-core/lib/HBS2/Net/Messaging/TCP.hs +++ b/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 diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 412398bf..f79eb8f0 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/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 diff --git a/hbs2-peer/app/RPC2.hs b/hbs2-peer/app/RPC2.hs index 2bb15603..7ed4ae4e 100644 --- a/hbs2-peer/app/RPC2.hs +++ b/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 diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs index 99eb24dc..fc2652c5 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs +++ b/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