@@ -1,38 +1,55 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE NamedFieldPuns #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE PackageImports #-}
6+{-# LANGUAGE RankNTypes #-}
17{-# LANGUAGE ScopedTypeVariables #-}
2−{-# LANGUAGE DataKinds #-}
3−{-# LANGUAGE LambdaCase #-}
4−{-# LANGUAGE NamedFieldPuns #-}
5−{-# LANGUAGE PackageImports #-}
6−{-# LANGUAGE TypeOperators #-}
8+{-# LANGUAGE TypeOperators #-}
79
8−module Katip.Scribes.Rollbar where
10+module Katip.Scribes.Rollbar
11+ ( mkRollbarScribe
12+ ) where
913
1014import Prelude hiding (error)
1115
12−import "base" Control.Exception (SomeException, Exception, catch)
13−import "base" Control.Monad (when)
16+import "base" Control.Monad (replicateM, when)
17+import "base" Data.Foldable (for_)
1418import "base" Data.Functor (void)
19+import "base" GHC.Conc (atomically)
1520
16−import "aeson" Data.Aeson (Value)
17−import "text" Data.Text.Lazy (toStrict)
18−import "text" Data.Text.Lazy.Builder (toLazyText)
21+import "async" Control.Concurrent.Async (async, waitCatch)
22+import "stm-chans" Control.Concurrent.STM.TBMQueue
23+ ( TBMQueue
24+ , closeTBMQueue
25+ , newTBMQueueIO
26+ , readTBMQueue
27+ , writeTBMQueue
28+ )
29+import "aeson" Data.Aeson (Value)
30+import "text" Data.Text.Lazy (toStrict)
31+import "text" Data.Text.Lazy.Builder (toLazyText)
32+import "time" Data.Time.Clock (UTCTime)
1933import "katip" Katip
2034 ( LogItem
21− , Scribe(Scribe, liPush, scribeFinalizer)
22− , Severity(DebugS, ErrorS, InfoS, NoticeS, WarningS)
35+ , Scribe(..)
36+ , Severity(..)
2337 , Verbosity
2438 , getEnvironment
2539 , itemJson
26− , payloadObject
2740 , permitItem
2841 , unLogStr
2942 , _itemEnv
43+ , _itemHost
3044 , _itemMessage
3145 , _itemSeverity
46+ , _itemTime
3247 )
33−import "http-client" Network.HTTP.Client (Manager)
34−import "rollbar-hs" Rollbar.AccessToken (AccessToken)
35−import "rollbar-hs" Rollbar.API (itemsPOST')
48+import "katip" Katip.Core (PermitFunc)
49+import "hostname" Network.HostName (HostName)
50+import "http-client" Network.HTTP.Client (Manager)
51+import "rollbar-hs" Rollbar.AccessToken (AccessToken)
52+import "rollbar-hs" Rollbar.API (itemsPOST')
3653import "rollbar-hs" Rollbar.Item
3754 ( Item(Item, accessToken, itemData)
3855 , critical
@@ -41,41 +58,71 @@ import "rollbar-hs" Rollbar.Item
4158 , info
4259 , warning
4360 )
44−import "rollbar-hs" Rollbar.Item.Body (MessageBody(MessageBody))
45−import "rollbar-hs" Rollbar.Item.Data (Data)
46−import "rollbar-hs" Rollbar.Item.Environment (Environment(Environment))
47−import "rollbar-hs" Rollbar.Item.MissingHeaders (RemoveHeaders)
61+import "rollbar-hs" Rollbar.Item.Body (MessageBody(MessageBody))
62+import "rollbar-hs" Rollbar.Item.CodeVersion (CodeVersion)
63+import "rollbar-hs" Rollbar.Item.Data
64+ ( Data(framework, server, timestamp)
65+ )
66+import "rollbar-hs" Rollbar.Item.Environment (Environment(Environment))
67+import "rollbar-hs" Rollbar.Item.MissingHeaders (RemoveHeaders)
68+import "rollbar-hs" Rollbar.Item.Server
69+ ( Branch
70+ , Server(Server, branch, host, root, serverCodeVersion)
71+ )
4872
4973import qualified "katip" Katip
5074
51−mkRollbarScribe ::
52− RemoveHeaders headers =>
53− proxy headers ->
54− AccessToken ->
55− Manager ->
56− Severity ->
57− Verbosity ->
58− IO Scribe
59−mkRollbarScribe proxy accessToken manager severity verbosity = do
60− let liPush item = when (permitItem severity item) $ do
61− void (itemsPOST' manager $ rollbarItem' item)
62− rollbarItem' item = rollbarItem proxy accessToken item verbosity
63− scribeFinalizer = pure ()
64− pure Scribe { liPush, scribeFinalizer }
75+queueSize :: Int
76+queueSize = 4096
77+
78+workerSize :: Int
79+workerSize = 10
80+
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
92+ queue <- newTBMQueueIO queueSize
93+ workers <- replicateM workerSize (async $ mkWorker proxy manager queue)
94+ let liPush item =
95+ atomically (writeTBMQueue queue $ rollbarItem' item)
96+ rollbarItem' item = rollbarItem proxy accessToken branch codeVersion verbosity item
97+ scribeFinalizer = do
98+ atomically (closeTBMQueue queue)
99+ for_ workers waitCatch
100+ pure Scribe { liPush, scribeFinalizer, scribePermitItem }
65101
66102rollbarItem ::
67103 (LogItem a, RemoveHeaders headers) =>
68104 proxy headers ->
69105 AccessToken ->
70− Katip.Item a ->
106+ Maybe Branch ->
107+ Maybe CodeVersion ->
71108 Verbosity ->
109+ Katip.Item a ->
72110 Item Value ("Authorization" ': headers)
73−rollbarItem _ accessToken item verbosity = Item { accessToken, itemData }
111+rollbarItem _ accessToken branch serverCodeVersion verbosity item =
112+ Item { accessToken, itemData }
74113 where
75114 environment :: Environment
76115 environment = Environment (getEnvironment $ _itemEnv item)
116+ hostName :: HostName
117+ hostName = _itemHost item
77118 itemData :: Data Value ("Authorization" ': headers)
78− itemData = case severity of
119+ itemData = itemData'
120+ { framework = Just "katip"
121+ , server = Just server
122+ , timestamp = Just timestamp
123+ }
124+ itemData' :: Data Value ("Authorization" ': headers)
125+ itemData' = case severity of
79126 DebugS -> debug environment (Just messageBody) value
80127 InfoS -> info environment (Just messageBody) value
81128 NoticeS -> info environment (Just messageBody) value
@@ -85,7 +132,25 @@ rollbarItem _ accessToken item verbosity = Item { accessToken, itemData }
85132 messageBody :: MessageBody
86133 messageBody =
87134 MessageBody (toStrict $ toLazyText $ unLogStr $ _itemMessage item)
135+ server :: Server
136+ server = Server { branch, host = Just hostName, root = Nothing, serverCodeVersion }
88137 severity :: Severity
89138 severity = _itemSeverity item
139+ timestamp :: UTCTime
140+ timestamp = _itemTime item
90141 value :: Value
91142 value = itemJson verbosity item
143+
144+mkWorker ::
145+ (RemoveHeaders headers) =>
146+ proxy headers ->
147+ Manager ->
148+ TBMQueue (Item Value ("Authorization" ': headers)) ->
149+ IO ()
150+mkWorker _ manager queue = go
151+ where
152+ go = do
153+ item' <- atomically (readTBMQueue queue)
154+ for_ item' $ \item -> do
155+ void (itemsPOST' manager item)
156+ go