@@ -3,20 +3,22 @@
33{-# LANGUAGE NamedFieldPuns #-}
44{-# LANGUAGE OverloadedStrings #-}
55{-# LANGUAGE PackageImports #-}
6+{-# LANGUAGE RankNTypes #-}
67{-# LANGUAGE ScopedTypeVariables #-}
78{-# LANGUAGE TypeOperators #-}
89
9−module Katip.Scribes.Rollbar where
10+module Katip.Scribes.Rollbar
11+ ( mkRollbarScribe
12+ ) where
1013
1114import Prelude hiding (error)
1215
13−import "base" Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
14−import "base" Control.Monad (replicateM, when)
15−import "base" Data.Foldable (for_)
16−import "base" Data.Functor (void)
17−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)
1820
19−import "async" Control.Concurrent.Async (async, waitCatchSTM)
21+import "async" Control.Concurrent.Async (async, waitCatch)
2022import "stm-chans" Control.Concurrent.STM.TBMQueue
2123 ( TBMQueue
2224 , closeTBMQueue
@@ -30,8 +32,8 @@ import "text" Data.Text.Lazy.Builder (toLazyText)
3032import "time" Data.Time.Clock (UTCTime)
3133import "katip" Katip
3234 ( LogItem
33− , Scribe(Scribe, liPush, scribeFinalizer)
34− , Severity(DebugS, ErrorS, InfoS, NoticeS, WarningS)
35+ , Scribe(..)
36+ , Severity(..)
3537 , Verbosity
3638 , getEnvironment
3739 , itemJson
@@ -43,6 +45,7 @@ import "katip" Katip
4345 , _itemSeverity
4446 , _itemTime
4547 )
48+import "katip" Katip.Core (PermitFunc)
4649import "hostname" Network.HostName (HostName)
4750import "http-client" Network.HTTP.Client (Manager)
4851import "rollbar-hs" Rollbar.AccessToken (AccessToken)
@@ -70,32 +73,31 @@ import "rollbar-hs" Rollbar.Item.Server
7073import qualified "katip" Katip
7174
7275queueSize :: Int
73−queueSize = 10
76+queueSize = 4096
7477
7578workerSize :: Int
76−workerSize = 3
79+workerSize = 10
7780
78−mkRollbarScribe ::
79− RemoveHeaders headers =>
80− proxy headers ->
81− AccessToken ->
82− Maybe Branch ->
83− Maybe CodeVersion ->
84− Manager ->
85− Severity ->
86− Verbosity ->
87− IO Scribe
88−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
8992 queue <- newTBMQueueIO queueSize
90− finalize <- newEmptyMVar
91− setupWorkers proxy queue finalize manager
92− let liPush item = when (permitItem severity item) $
93+ workers <- replicateM workerSize (async $ mkWorker proxy manager queue)
94+ let liPush item =
9395 atomically (writeTBMQueue queue $ rollbarItem' item)
9496 rollbarItem' item = rollbarItem proxy accessToken branch codeVersion verbosity item
9597 scribeFinalizer = do
96− putMVar finalize ()
97− takeMVar finalize
98− pure Scribe { liPush, scribeFinalizer }
98+ atomically (closeTBMQueue queue)
99+ for_ workers waitCatch
100+ pure Scribe { liPush, scribeFinalizer, scribePermitItem }
99101
100102rollbarItem ::
101103 (LogItem a, RemoveHeaders headers) =>
@@ -139,23 +141,6 @@ rollbarItem _ accessToken branch serverCodeVersion verbosity item =
139141 value :: Value
140142 value = itemJson verbosity item
141143
142−-- | Setup the workers and wait until the finalizer is evaluated.
143−-- Then, close the queueu, wait for the workers and continue finalization.
144−setupWorkers ::
145− RemoveHeaders headers =>
146− proxy headers ->
147− TBMQueue (Item Value ("Authorization" ': headers)) ->
148− MVar () ->
149− Manager ->
150− IO ()
151−setupWorkers proxy queue finalize manager = void $ async $ do
152− workers <- replicateM workerSize (async $ mkWorker proxy manager queue)
153− takeMVar finalize
154− atomically $ do
155− closeTBMQueue queue
156− for_ workers waitCatchSTM
157− putMVar finalize ()
158−
159144mkWorker ::
160145 (RemoveHeaders headers) =>
161146 proxy headers ->