{-# LANGUAGE TupleSections, OverloadedLists, ScopedTypeVariables, RecordWildCards #-}
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

-- import Control.Effects

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