Merge pull request #134 from istathar/rate-limit

Limit the rate which telemetry is read from queue

Author: istathar

core-program/core-program.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           core-program
-version:        0.5.0.1
+version:        0.5.0.2
 synopsis:       Opinionated Haskell Interoperability
 description:    A library to help build command-line programs, both tools and
                 longer-running daemons.

core-program/lib/Core/Program/Execute.hs

@@ -401,7 +401,7 @@ loopForever :: ([a] -> IO ()) -> MVar Verbosity -> TQueue (Maybe Rope) -> TQueue
 loopForever action v out queue = do
     -- block waiting for an item
     possibleItems <- atomically $ do
-        cycleOverQueue []
+        cycleOverQueue 0 []
 
     case possibleItems of
         -- we're done!
@@ -419,7 +419,12 @@ loopForever action v out queue = do
                 )
             loopForever action v out queue
   where
-    cycleOverQueue items =
+    cycleOverQueue !count items =
+        if count >= (1024 :: Int)
+            then pure (Just items)
+            else cycleOverQueue' count items
+
+    cycleOverQueue' !count items =
         case items of
             [] -> do
                 possibleItem <- readTQueue queue -- blocks
@@ -428,7 +433,7 @@ loopForever action v out queue = do
                     Nothing -> pure Nothing
                     -- otherwise start accumulating
                     Just item -> do
-                        cycleOverQueue (item : [])
+                        cycleOverQueue 1 (item : [])
             _ -> do
                 pending <- tryReadTQueue queue -- doesn't block
                 case pending of
@@ -446,7 +451,7 @@ loopForever action v out queue = do
                                 pure (Just items)
                             -- continue accumulating!
                             Just item -> do
-                                cycleOverQueue (item : items)
+                                cycleOverQueue (count + 1) (item : items)
 
     reportStatus start num = do
         level <- readMVar v

core-program/package.yaml

@@ -1,5 +1,5 @@
 name: core-program
-version: 0.5.0.1
+version: 0.5.0.2
 synopsis: Opinionated Haskell Interoperability
 description: |
   A library to help build command-line programs, both tools and

core-telemetry/core-telemetry.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.18
 -- see: https://github.com/sol/hpack
 
 name:           core-telemetry
-version:        0.2.3.2
+version:        0.2.3.3
 synopsis:       Advanced telemetry
 description:    This is part of a library to help build command-line programs, both tools and
                 longer-running daemons.
@@ -52,9 +52,9 @@ library
       async
     , base >=4.11 && <5
     , bytestring
-    , core-data >=0.3.3
-    , core-program >=0.5.0
-    , core-text >=0.3.7
+    , core-data >=0.3.3.1
+    , core-program >=0.5.0.2
+    , core-text >=0.3.7.1
     , exceptions
     , http-streams
     , io-streams

core-telemetry/package.yaml

@@ -1,5 +1,5 @@
 name: core-telemetry
-version: 0.2.3.2
+version: 0.2.3.3
 synopsis: Advanced telemetry
 description: |
   This is part of a library to help build command-line programs, both tools and
@@ -33,9 +33,9 @@ dependencies:
 library:
   dependencies:
    - async
-   - core-text >= 0.3.7
-   - core-data >= 0.3.3
-   - core-program >= 0.5.0
+   - core-text >= 0.3.7.1
+   - core-data >= 0.3.3.1
+   - core-program >= 0.5.0.2
    - exceptions
    - http-streams
    - io-streams

core-text/core-text.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.18
 -- see: https://github.com/sol/hpack
 
 name:           core-text
-version:        0.3.7.2
+version:        0.3.7.3
 synopsis:       A rope type based on a finger tree over UTF-8 fragments
 description:    A rope data type for text, built as a finger tree over UTF-8 text
                 fragments. The package also includes utiltiy functions for breaking and

core-text/lib/Core/Text/Utilities.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -52,13 +53,13 @@ import Core.Text.Colour
 import Core.Text.Parsing
 import Core.Text.Rope
 import Data.Bits (Bits (..))
-import qualified Data.ByteString as B (ByteString, length, splitAt, unpack)
+import Data.ByteString qualified as B (ByteString, length, splitAt, unpack)
 import Data.Char (intToDigit)
-import qualified Data.FingerTree as F (ViewL (..), viewl, (<|))
+import Data.FingerTree qualified as F (ViewL (..), viewl, (<|))
 import Data.Kind (Type)
-import qualified Data.List as List (dropWhileEnd, foldl', splitAt)
-import qualified Data.Text as T
-import qualified Data.Text.Short as S (
+import Data.List qualified as List (dropWhileEnd, foldl', splitAt)
+import Data.Text qualified as T
+import Data.Text.Short qualified as S (
     ShortText,
     replicate,
     singleton,
@@ -164,10 +165,9 @@ twoWords ds = go ds
   where
     go [] = []
     go [x] = [softline' <> x]
-    go xs =
-        let (one : two : [], remainder) = List.splitAt 2 xs
-         in group (one <> spacer <> two) : go remainder
-
+    go xs = case List.splitAt 2 xs of
+        (one : two : [], remainder) -> group (one <> spacer <> two) : go remainder
+        _ -> [] -- unreachable
     spacer = flatAlt softline' "  "
 
 byteChunk :: B.ByteString -> [B.ByteString]
@@ -316,7 +316,6 @@ Sadly if there is only one item you don't get an Oxford comma, either:
 λ> __oxford []__
 ""
 @
-
 -}
 oxford :: [Rope] -> Rope
 oxford [] = emptyRope

core-text/package.yaml

@@ -1,5 +1,5 @@
 name: core-text
-version: 0.3.7.2
+version: 0.3.7.3
 synopsis: A rope type based on a finger tree over UTF-8 fragments
 description: |
   A rope data type for text, built as a finger tree over UTF-8 text

stack.yaml

@@ -1,4 +1,4 @@
-resolver: nightly-2022-05-28
+resolver: nightly-2022-06-06
 packages:
  - ./core-data
  - ./core-text