Merge branch 'compress-events'

Author: istathar

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.3
+version:        0.2.3.4
 synopsis:       Advanced telemetry
 description:    This is part of a library to help build command-line programs, both tools and
                 longer-running daemons.
@@ -67,4 +67,5 @@ library
     , template-haskell >=2.14 && <3
     , text
     , unix
+    , zlib
   default-language: Haskell2010

core-telemetry/lib/Core/Telemetry/Honeycomb.hs

@@ -35,8 +35,9 @@ module Core.Telemetry.Honeycomb (
     honeycombExporter,
 ) where
 
+import Codec.Compression.GZip qualified as GZip (compress)
 import Control.Exception.Safe qualified as Safe (catch, finally, throw)
-import Core.Data.Clock (Time, unTime, getCurrentTimeNanoseconds)
+import Core.Data.Clock (Time, getCurrentTimeNanoseconds, unTime)
 import Core.Data.Structures (Map, fromMap, insertKeyValue, intoMap, lookupKeyValue)
 import Core.Encoding.Json
 import Core.Program.Arguments
@@ -49,6 +50,8 @@ import Core.Text.Rope
 import Core.Text.Utilities
 import Data.ByteString (ByteString)
 import Data.ByteString qualified as B (ByteString)
+import Data.ByteString.Builder (Builder)
+import Data.ByteString.Builder qualified as Builder (lazyByteString)
 import Data.ByteString.Char8 qualified as C (append, null, putStrLn)
 import Data.ByteString.Lazy qualified as L (ByteString)
 import Data.Fixed
@@ -57,7 +60,8 @@ import Data.List qualified as List
 import Network.Http.Client
 import System.Environment (lookupEnv)
 import System.Exit (ExitCode (..))
-import System.IO.Streams (InputStream)
+import System.IO.Streams (InputStream, OutputStream)
+import System.IO.Streams qualified as Streams (write)
 import System.Posix.Process qualified as Posix (exitImmediately)
 
 {- |
@@ -233,6 +237,13 @@ cleanupConnection r = do
             writeIORef r Nothing
         )
 
+compressBody :: Bytes -> OutputStream Builder -> IO ()
+compressBody bytes o = do
+    let x = fromBytes bytes
+    let x' = GZip.compress x
+    let b = Builder.lazyByteString x'
+    Streams.write (Just b) o
+
 postEventToHoneycombAPI :: IORef (Maybe Connection) -> ApiKey -> Dataset -> JsonValue -> IO ()
 postEventToHoneycombAPI r apikey dataset json = attempt False
   where
@@ -242,7 +253,7 @@ postEventToHoneycombAPI r apikey dataset json = attempt False
                 c <- acquireConnection r
 
                 -- actually transmit telemetry to Honeycomb
-                sendRequest c q (simpleBody (fromBytes (encodeToUTF8 json)))
+                sendRequest c q (compressBody (encodeToUTF8 json))
                 receiveResponse c handler
             )
             ( \(e :: SomeException) -> do
@@ -251,14 +262,17 @@ postEventToHoneycombAPI r apikey dataset json = attempt False
                 cleanupConnection r
                 case retrying of
                     False -> do
-                        putStrLn "Reattempting"
+                        putStrLn "internal: Reconnecting to Honeycomb"
                         attempt True
-                    True -> Safe.throw e
+                    True -> do
+                        putStrLn "internal: Failed to re-establish connection to Honeycomb"
+                        Safe.throw e
             )
 
     q = buildRequest1 $ do
         http POST (fromRope ("/1/batch/" <> dataset))
         setContentType "application/json"
+        setHeader "Content-Encoding" "gzip"
         setHeader "X-Honeycomb-Team" (fromRope (apikey))
 
     {-
@@ -285,7 +299,7 @@ postEventToHoneycombAPI r apikey dataset json = attempt False
                                     pure ()
                                 _ -> do
                                     -- some other status!
-                                    putStrLn "Unexpected status returned;"
+                                    putStrLn "internal: Unexpected status returned;"
                                     C.putStrLn body
                             _ -> putStrLn "internal: wtf?"
                     _ -> do

core-telemetry/package.yaml

@@ -1,5 +1,5 @@
 name: core-telemetry
-version: 0.2.3.3
+version: 0.2.3.4
 synopsis: Advanced telemetry
 description: |
   This is part of a library to help build command-line programs, both tools and
@@ -46,6 +46,7 @@ library:
    - scientific
    - stm
    - unix
+   - zlib
   source-dirs:
   - lib
   exposed-modules: