@@ -3,6 +3,7 @@
33{-# LANGUAGE NamedFieldPuns #-}
44{-# LANGUAGE OverloadedStrings #-}
55{-# LANGUAGE PackageImports #-}
6+{-# LANGUAGE RankNTypes #-}
67{-# LANGUAGE ScopedTypeVariables #-}
78{-# LANGUAGE TypeOperators #-}
89
@@ -12,11 +13,10 @@ module Katip.Scribes.Rollbar
1213
1314import Prelude hiding (error)
1415
15−import "base" Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
16−import "base" Control.Monad (replicateM, when)
17−import "base" Data.Foldable (for_)
18−import "base" Data.Functor (void)
19−import "base" GHC.Conc (atomically)
16+import "base" Control.Monad (replicateM, when)
17+import "base" Data.Foldable (for_)
18+import "base" Data.Functor (void)
19+import "base" GHC.Conc (atomically)
2020
2121import "async" Control.Concurrent.Async (async, waitCatch)
2222import "stm-chans" Control.Concurrent.STM.TBMQueue
@@ -32,8 +32,8 @@ import "text" Data.Text.Lazy.Builder (toLazyText)
3232import "time" Data.Time.Clock (UTCTime)
3333import "katip" Katip
3434 ( LogItem
35− , Scribe(Scribe, liPush, scribeFinalizer)
36− , Severity(DebugS, ErrorS, InfoS, NoticeS, WarningS)
35+ , Scribe(..)
36+ , Severity(..)
3737 , Verbosity
3838 , getEnvironment
3939 , itemJson
@@ -45,6 +45,7 @@ import "katip" Katip
4545 , _itemSeverity
4646 , _itemTime
4747 )
48+import "katip" Katip.Core (PermitFunc)
4849import "hostname" Network.HostName (HostName)
4950import "http-client" Network.HTTP.Client (Manager)
5051import "rollbar-hs" Rollbar.AccessToken (AccessToken)
@@ -72,32 +73,31 @@ import "rollbar-hs" Rollbar.Item.Server
7273import qualified "katip" Katip
7374
7475queueSize :: Int
75−queueSize = 10
76+queueSize = 4096
7677
7778workerSize :: Int
78−workerSize = 3
79+workerSize = 10
7980
80−mkRollbarScribe ::
81− RemoveHeaders headers =>
82− proxy headers ->
83− AccessToken ->
84− Maybe Branch ->
85− Maybe CodeVersion ->
86− Manager ->
87− Severity ->
88− Verbosity ->
89− IO Scribe
90−mkRollbarScribe proxy accessToken branch codeVersion manager severity verbosity = do
81+mkRollbarScribe
82+ :: RemoveHeaders headers
83+ => proxy headers
84+ -> AccessToken
85+ -> Maybe Branch
86+ -> Maybe CodeVersion
87+ -> Manager -- ^ Must support TLS
88+ -> PermitFunc
89+ -> Verbosity
90+ -> IO Scribe
91+mkRollbarScribe proxy accessToken branch codeVersion manager scribePermitItem verbosity = do
9192 queue <- newTBMQueueIO queueSize
92− finalize <- newEmptyMVar
93− setupWorkers proxy queue finalize manager
94− let liPush item = when (permitItem severity item) $
93+ workers <- replicateM workerSize (async $ mkWorker proxy manager queue)
94+ let liPush item =
9595 atomically (writeTBMQueue queue $ rollbarItem' item)
9696 rollbarItem' item = rollbarItem proxy accessToken branch codeVersion verbosity item
9797 scribeFinalizer = do
98− putMVar finalize ()
99− takeMVar finalize
100− pure Scribe { liPush, scribeFinalizer }
98+ atomically (closeTBMQueue queue)
99+ for_ workers waitCatch
100+ pure Scribe { liPush, scribeFinalizer, scribePermitItem }
101101
102102rollbarItem ::
103103 (LogItem a, RemoveHeaders headers) =>
@@ -141,22 +141,6 @@ rollbarItem _ accessToken branch serverCodeVersion verbosity item =
141141 value :: Value
142142 value = itemJson verbosity item
143143
144−-- | Setup the workers and wait until the finalizer is evaluated.
145−-- Then, close the queueu, wait for the workers and continue finalization.
146−setupWorkers ::
147− RemoveHeaders headers =>
148− proxy headers ->
149− TBMQueue (Item Value ("Authorization" ': headers)) ->
150− MVar () ->
151− Manager ->
152− IO ()
153−setupWorkers proxy queue finalize manager = void $ async $ do
154− workers <- replicateM workerSize (async $ mkWorker proxy manager queue)
155− takeMVar finalize
156− atomically (closeTBMQueue queue)
157− for_ workers waitCatch
158− putMVar finalize ()
159−
160144mkWorker ::
161145 (RemoveHeaders headers) =>
162146 proxy headers ->