module Control.Effects.Logging.Sentry where
import Prelude (String)
import Interlude
import qualified Data.Vector as Vector
import qualified Data.HashMap.Strict as Map
import Text.ParserCombinators.ReadP
import Data.UUID
import Control.Lens hiding ((.=), Level, Context)
import Data.Aeson.Types (Value(..))
import Data.Aeson (toJSON, object, (.=))
import Network.Wreq
import Data.Time.ISO8601
import Data.Time (getCurrentTime)
import Control.Effects.Logging
tagToPair :: Tag -> (String, String)
tagToPair (Tag t) = (toS t, "")
levelToSentry :: Level -> Text
levelToSentry Fatal = "fatal"
levelToSentry Error = "error"
levelToSentry Warning = "warning"
levelToSentry Info = "info"
levelToSentry Debug = "debug"
data SentryService = SentryService { serviceEndpoint :: Text
, servicePublicKey :: Text
, serviceSecretKey :: Text }
deriving (Eq, Ord, Read, Show)
alphaNum :: ReadP Char
alphaNum = satisfy isAlphaNum
sentryServiceFromDSN :: Text -> SentryService
sentryServiceFromDSN txt = fst $ fromMaybe (error "Failed to parse DSN")
(listToMaybe (readP_to_S parser (toS txt)))
where parser = do
protocol <- many1 alphaNum
void $ string "://"
public <- many1 alphaNum
void $ char ':'
secret <- many1 alphaNum
void $ char '@'
host <- many1 (satisfy (const True))
void $ char '/'
projId <- many1 (satisfy isDigit)
eof
return (SentryService (toS $ protocol <> "://" <> host <> "/api/" <> projId <> "/store/")
(toS public)
(toS secret))
contextToFrame :: Context -> Value
contextToFrame (Context ctx) = object ["module" .= String ctx]
contextToFrames :: [Context] -> Value
contextToFrames ctxs = object
["frames" .= Array (Vector.fromList (reverse (top : fmap contextToFrame ctxs)))]
where top = object ["module" .= String "top layer"]
currentWreqOptions :: Text -> Text -> Text -> Network.Wreq.Options
currentWreqOptions stamp public secret =
defaults & header "X-Sentry-Auth" .~ [
"Sentry sentry_version=7,\
\sentry_client=0.1,\
\sentry_timestamp=" <> pshow stamp <> ",\
\sentry_key=" <> toS public <> ",\
\sentry_secret=" <> toS secret]
& header "Content-Type" .~ ["application/json"]
addInterface :: ToJSON a => Text -> Maybe a -> [(Text, Value)] -> [(Text, Value)]
addInterface _ Nothing is = is
addInterface name (Just a) is = (name, toJSON a) : is
logToSentry :: (MonadIO m, MonadRandom m) => SentryService -> EffectHandler Logging m a -> m a
logToSentry svc = handleLogging $ \Log{..} -> do
uuid :: UUID <- getRandom
time <- liftIO getCurrentTime
let stamp = toS $ formatISO8601 time
let opts = currentWreqOptions stamp (servicePublicKey svc) (serviceSecretKey svc)
let evId = filter (/= '-') (pshow uuid :: String)
let frames = contextToFrames logContext
let crumbs = Array (Vector.fromList (fmap toJSON logCrumbs))
let message = Object (Map.fromList (
[ ("event_id", String (toS evId))
, ("message", String logMessage)
, ("timestamp", String stamp)
, ("level", String (levelToSentry logLevel))
, ("logger", String "logger")
, ("platform", String "haskell")
, ("fingerprint", Array [String stamp])
, ("extra", object [("data", String (toS logData))])
, ("sentry.interfaces.Breadcrumbs", crumbs)
, ("sentry.interfaces.Stacktrace", frames) ]
& addInterface "sentry.interfaces.User" logUser))
void $ liftIO $ forkIO $ void $ postWith opts (toS $ serviceEndpoint svc) message