module Katip.Scribes.Rollbar
( mkRollbarScribe
) where
import Prelude hiding (error)
import "base" Control.Monad (replicateM, when)
import "base" Data.Foldable (for_)
import "base" Data.Functor (void)
import "base" GHC.Conc (atomically)
import "async" Control.Concurrent.Async (async, waitCatch)
import "stm-chans" Control.Concurrent.STM.TBMQueue
( TBMQueue
, closeTBMQueue
, newTBMQueueIO
, readTBMQueue
, writeTBMQueue
)
import "aeson" Data.Aeson (Value)
import "text" Data.Text.Lazy (toStrict)
import "text" Data.Text.Lazy.Builder (toLazyText)
import "time" Data.Time.Clock (UTCTime)
import "katip" Katip
( LogItem
, Scribe(Scribe, liPush, scribeFinalizer)
, Severity(DebugS, ErrorS, InfoS, NoticeS, WarningS)
, Verbosity
, getEnvironment
, itemJson
, permitItem
, unLogStr
, _itemEnv
, _itemHost
, _itemMessage
, _itemSeverity
, _itemTime
)
import "hostname" Network.HostName (HostName)
import "http-client" Network.HTTP.Client (Manager)
import "rollbar-hs" Rollbar.AccessToken (AccessToken)
import "rollbar-hs" Rollbar.API (itemsPOST')
import "rollbar-hs" Rollbar.Item
( Item(Item, accessToken, itemData)
, critical
, debug
, error
, info
, warning
)
import "rollbar-hs" Rollbar.Item.Body (MessageBody(MessageBody))
import "rollbar-hs" Rollbar.Item.CodeVersion (CodeVersion)
import "rollbar-hs" Rollbar.Item.Data
( Data(framework, server, timestamp)
)
import "rollbar-hs" Rollbar.Item.Environment (Environment(Environment))
import "rollbar-hs" Rollbar.Item.MissingHeaders (RemoveHeaders)
import "rollbar-hs" Rollbar.Item.Server
( Branch
, Server(Server, branch, host, root, serverCodeVersion)
)
import qualified "katip" Katip
queueSize :: Int
queueSize = 4096
workerSize :: Int
workerSize = 10
mkRollbarScribe
:: RemoveHeaders headers
=> proxy headers
-> AccessToken
-> Maybe Branch
-> Maybe CodeVersion
-> Manager
-> Severity
-> Verbosity
-> IO Scribe
mkRollbarScribe proxy accessToken branch codeVersion manager severity verbosity = do
queue <- newTBMQueueIO queueSize
workers <- replicateM workerSize (async $ mkWorker proxy manager queue)
let liPush item = when (permitItem severity item) $
atomically (writeTBMQueue queue $ rollbarItem' item)
rollbarItem' item = rollbarItem proxy accessToken branch codeVersion verbosity item
scribeFinalizer = do
atomically (closeTBMQueue queue)
for_ workers waitCatch
pure Scribe { liPush, scribeFinalizer }
rollbarItem ::
(LogItem a, RemoveHeaders headers) =>
proxy headers ->
AccessToken ->
Maybe Branch ->
Maybe CodeVersion ->
Verbosity ->
Katip.Item a ->
Item Value ("Authorization" ': headers)
rollbarItem _ accessToken branch serverCodeVersion verbosity item =
Item { accessToken, itemData }
where
environment :: Environment
environment = Environment (getEnvironment $ _itemEnv item)
hostName :: HostName
hostName = _itemHost item
itemData :: Data Value ("Authorization" ': headers)
itemData = itemData'
{ framework = Just "katip"
, server = Just server
, timestamp = Just timestamp
}
itemData' :: Data Value ("Authorization" ': headers)
itemData' = case severity of
DebugS -> debug environment (Just messageBody) value
InfoS -> info environment (Just messageBody) value
NoticeS -> info environment (Just messageBody) value
WarningS -> warning environment (Just messageBody) value
ErrorS -> error environment (Just messageBody) value
_ -> critical environment (Just messageBody) value
messageBody :: MessageBody
messageBody =
MessageBody (toStrict $ toLazyText $ unLogStr $ _itemMessage item)
server :: Server
server = Server { branch, host = Just hostName, root = Nothing, serverCodeVersion }
severity :: Severity
severity = _itemSeverity item
timestamp :: UTCTime
timestamp = _itemTime item
value :: Value
value = itemJson verbosity item
mkWorker ::
(RemoveHeaders headers) =>
proxy headers ->
Manager ->
TBMQueue (Item Value ("Authorization" ': headers)) ->
IO ()
mkWorker _ manager queue = go
where
go = do
item' <- atomically (readTBMQueue queue)
for_ item' $ \item -> do
void (itemsPOST' manager item)
go