From 9fadbae77777e778a78777fb4695d25b86a3d87e Mon Sep 17 00:00:00 2001
From: Mats Rauhala <mats.rauhala@iki.fi>
Date: Tue, 25 Aug 2026 19:37:57 +0300
Subject: [PATCH] writerAction: drain, dedupe, and rate-limit outbound calls

---
 src/HomeAssistant/Runtime/Connection.hs | 37 +++++++++++++++++++++----
 1 file changed, 32 insertions(+), 5 deletions(-)

diff --git a/src/HomeAssistant/Runtime/Connection.hs b/src/HomeAssistant/Runtime/Connection.hs
index f17ac00..3031688 100644
--- a/src/HomeAssistant/Runtime/Connection.hs
+++ b/src/HomeAssistant/Runtime/Connection.hs
@@ -9,10 +9,12 @@ module HomeAssistant.Runtime.Connection
   ) where
 
 import Control.Concurrent.STM
-  ( atomically
+  ( TChan
+  , atomically
   , readTChan
   , readTVar
   , retry
+  , tryReadTChan
   , writeTChan
   , writeTVar
   )
@@ -103,16 +105,41 @@ receiveJSON conn = do
     Left err -> throw (Fatal $ "Invalid JSON from Home Assistant: " <> T.pack err)
     Right x  -> pure x
 
-writerAction :: Bus -> IO Void
-writerAction bus = forever $ do
-  (request, svc) <- atomically $ readTChan (busOutbound bus)
-  conn <- atomically $ readTVar (busConn bus) >>= maybe retry pure
+-- | Floor between sends within a batch: 100ms, so a many-distinct-target
+-- flood still caps at ~10 sends/sec even after dedupe.
+minInterval :: Int
+minInterval = 100000
+
+-- | Non-blocking drain of everything queued on a channel. Returns items
+-- oldest-first (FIFO from the channel), so prepending the blocking
+-- `readTChan` item keeps the whole batch oldest-first for `dedupeBatch`.
+drainTry :: TChan a -> IO [a]
+drainTry chan = go []
+  where
+    go acc = do
+      m <- atomically $ tryReadTChan chan
+      case m of
+        Nothing -> pure (reverse acc)
+        Just x  -> go (x : acc)
+
+sendWithId :: Bus -> WS.Connection -> Request -> Service -> IO ()
+sendWithId bus conn request svc = do
   callId <- generateCallId (busGen bus)
   let textData = encode $ encodeService callId svc
   runKatipContextT (busLogEnv bus) (sl "traceId" (toText (requestTraceId request))) "connection" $
     logFM DebugS (ls textData)
   WS.sendTextData conn textData
 
+writerAction :: Bus -> IO Void
+writerAction bus = forever $ do
+  first <- atomically $ readTChan (busOutbound bus)
+  rest  <- drainTry (busOutbound bus)
+  let deduped = dedupeBatch (first : rest)
+  conn <- atomically $ readTVar (busConn bus) >>= maybe retry pure
+  forM_ deduped $ \(request, svc) -> do
+    sendWithId bus conn request svc
+    threadDelay minInterval
+
 encodeService :: Int -> Service -> Value
 encodeService callId Service{..} = object $
   [ "id"      .= callId