module Network.Yeller.Internals where
import qualified Data.Map as M
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.ByteString.Lazy as LBS
import qualified GHC.Stack
import qualified Control.Exception
import qualified Data.Typeable
import qualified Data.Aeson as JSON
import qualified Network.BSD
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Types as HTTPStatus
import qualified Network.HTTP.Client.TLS as TLS
import System.IO as IO
import qualified Control.Concurrent.STM as STM
import Control.Applicative((<$>))
import Data.Monoid((<>))
data ErrorNotification a = ErrorNotification {
errorType :: T.Text
, errorMessage :: T.Text
, errorStackTrace :: [StackFrame]
, errorHost :: T.Text
, errorEnvironment :: T.Text
, errorClientVersion :: T.Text
, errorExtra :: ExtraErrorInfo a
} deriving (Show, Eq)
data StackFrame = StackFrame {
stackFilename :: T.Text
, stackLineNumber :: T.Text
, stackFunction :: T.Text
, stackOptions :: StackOptions
} deriving (Show, Eq)
data StackOptions = StackOptions {
stackOptionsInApp :: Bool
} deriving (Show, Eq)
data ExtraErrorInfo a = ExtraErrorInfo {
errorURL :: Maybe T.Text
, errorCustomData :: Maybe (M.Map T.Text a)
, errorLocation :: Maybe T.Text
, errorUser :: Maybe UserInfo
, errorHTTPRequest :: Maybe HTTPRequest
} deriving (Show, Eq)
data UserInfo = UserInfo {
userID :: Integer
} deriving (Show, Eq)
instance JSON.ToJSON UserInfo where
toJSON u = JSON.object ["id" JSON..= userID u]
emptyExtraErrorInfo :: ExtraErrorInfo Int
emptyExtraErrorInfo = ExtraErrorInfo Nothing Nothing Nothing Nothing Nothing
data HTTPRequest = HTTPRequest {
httpRequestUserAgent :: T.Text
} deriving (Show, Eq)
instance JSON.ToJSON HTTPRequest where
toJSON h = JSON.object ["user-agent" JSON..= httpRequestUserAgent h]
instance JSON.ToJSON StackOptions where
toJSON s = JSON.object ["in-app" JSON..= stackOptionsInApp s]
instance JSON.ToJSON StackFrame where
toJSON s = JSON.toJSON (stackFilename s, stackLineNumber s, stackFunction s, stackOptions s)
instance (JSON.ToJSON b) => JSON.ToJSON (ErrorNotification b) where
toJSON e = JSON.object ["type" JSON..= errorType e
, "message" JSON..= errorMessage e
, "stacktrace" JSON..= errorStackTrace e
, "host" JSON..= errorHost e
, "application-environment" JSON..= errorEnvironment e
, "client-version" JSON..= errorClientVersion e
, "url" JSON..= errorURL ( errorExtra e)
, "location" JSON..= errorLocation ( errorExtra e)
, "custom-data" JSON..= makeJSONCustomData ( errorExtra e)
]
makeJSONCustomData :: JSON.ToJSON a => ExtraErrorInfo a -> JSON.Value
makeJSONCustomData e = JSON.toJSON (maybeAddHTTPUserAgent e (maybeAddUser e withJSONVals))
where withJSONVals = M.map JSON.toJSON (maybeOr (errorCustomData e) M.empty)
maybeAddUser :: ExtraErrorInfo a -> M.Map T.Text JSON.Value -> M.Map T.Text JSON.Value
maybeAddUser (ExtraErrorInfo { errorUser = Nothing } ) m = m
maybeAddUser (ExtraErrorInfo { errorUser = (Just user) }) m =
case M.lookup "user" m of
Nothing -> M.insert "user" (JSON.toJSON user) m
(Just (JSON.Object u)) -> M.insert "user" (JSON.Object (HM.insert "id" (JSON.toJSON (userID user)) u)) m
(Just _) -> m
maybeAddHTTPUserAgent :: ExtraErrorInfo a -> M.Map T.Text JSON.Value -> M.Map T.Text JSON.Value
maybeAddHTTPUserAgent (ExtraErrorInfo { errorHTTPRequest = Nothing } ) m = m
maybeAddHTTPUserAgent (ExtraErrorInfo { errorHTTPRequest = (Just http) }) m =
case M.lookup "http-request" m of
Nothing -> M.insert "http-request" (JSON.toJSON http) m
(Just (JSON.Object h)) -> M.insert "http-request" (JSON.Object (HM.insert "user-agent" (JSON.toJSON (httpRequestUserAgent http)) h)) m
(Just _) -> m
maybeOr :: Maybe a -> a -> a
maybeOr (Just a) _ = a
maybeOr Nothing a = a
yellerVersion :: T.Text
yellerVersion = T.pack "yeller-haskell: 0.1.0.4"
newtype Backend = Backend T.Text
data YellerClient = YellerClient {
clientToken :: T.Text
, clientHost :: T.Text
, clientEnvironment :: T.Text
, clientVersion :: T.Text
, clientApplicationPackage :: T.Text
, clientManager :: HTTP.Manager
, clientBackends :: STM.TVar [Backend]
, clientErrorHandler :: YellerClientErrorHandler
, clientMaxRetries :: Int
} | DisabledYellerClient
data YellerClientErrorHandler = YellerClientErrorHandler {
handleAuthenticationErrors :: HTTP.Response HTTP.BodyReader -> IO ()
, handleIOErrors :: Control.Exception.SomeException -> ErrorNotification JSON.Value -> IO ()
}
data ApplicationEnvironment =
TestEnvironment |
ApplicationEnvironment T.Text
newtype ApplicationPackage = ApplicationPackage T.Text
newtype YellerToken = YellerToken T.Text
data YellerClientSettings = YellerClientSettings {
clientSettingsToken :: YellerToken
, clientSettingsHost :: Maybe T.Text
, clientSettingsEnvironment :: ApplicationEnvironment
, clientSettingsApplicationPackage :: ApplicationPackage
, clientSettingsBackends :: [Backend]
, clientSettingsErrorHandler :: YellerClientErrorHandler
, clientSettingsMaxRetries :: Int
}
defaultClientSettings :: YellerClientSettings
defaultClientSettings = YellerClientSettings {
clientSettingsToken = YellerToken bogusClientToken
, clientSettingsHost = Nothing
, clientSettingsEnvironment = ApplicationEnvironment "production"
, clientSettingsApplicationPackage = ApplicationPackage ""
, clientSettingsBackends = map Backend defaultBackends
, clientSettingsErrorHandler = defaultErrorHandler
, clientSettingsMaxRetries = 10
}
defaultErrorHandler :: YellerClientErrorHandler
defaultErrorHandler = YellerClientErrorHandler {
handleAuthenticationErrors = \_ -> IO.hPutStrLn stderr "Failed to authenticate with the yeller servers. Check your api key is correct and try again."
, handleIOErrors = \x n -> IO.hPrint stderr ("Error sending an exception to Yeller: " :: String, x, n)
}
bogusClientToken :: T.Text
bogusClientToken = "YOUR_API_TOKEN_HERE"
defaultBackends :: [T.Text]
defaultBackends = [
"https://collector1.yellerapp.com/"
, "https://collector2.yellerapp.com/"
, "https://collector3.yellerapp.com/"
, "https://collector4.yellerapp.com/"
, "https://collector5.yellerapp.com/"
]
class (Data.Typeable.Typeable a, Show a) => ToError a where
toError :: a -> ErrorNotification b -> ErrorNotification b
instance ToError Control.Exception.SomeException where
toError = defaultToError
defaultToError :: (Data.Typeable.Typeable e, Show e) => e -> ErrorNotification b -> ErrorNotification b
defaultToError e current = current {
errorType = T.pack . show $ Data.Typeable.typeOf e
, errorMessage = T.pack $ show e
}
parseStackLine :: String -> StackFrame
parseStackLine x = StackFrame {
stackFilename = filename
, stackLineNumber = line
, stackFunction = function
, stackOptions = StackOptions { stackOptionsInApp = True }
}
where encoded = T.pack x
function = T.takeWhile (/= ' ') encoded
afterFunction = T.tail $ T.dropWhile (/= ' ') encoded
filename = manageNoLocationFilename $ T.dropWhile (== '(') $ T.takeWhile (/= ':') afterFunction
afterFilename = T.dropWhile (== ':') $ T.dropWhile (/= ':') afterFunction
line = T.take (T.length afterFilename 1) afterFilename
manageNoLocationFilename :: T.Text -> T.Text
manageNoLocationFilename t
| t == "<no location info>)" = ""
| otherwise = t
parseStackTrace :: [String] -> [StackFrame]
parseStackTrace = filter ((/= "Network.Yeller.sendError") . stackFunction) . map parseStackLine
markInApp :: T.Text -> StackFrame -> StackFrame
markInApp package frame
| T.isPrefixOf package (stackFunction frame) = frame { stackOptions = StackOptions {stackOptionsInApp = True } }
| otherwise = frame { stackOptions = StackOptions {stackOptionsInApp = False } }
filterInAppLines :: T.Text -> [StackFrame] -> [StackFrame]
filterInAppLines package = map (markInApp package)
sendError :: (ToError e, JSON.ToJSON a) => YellerClient -> e -> ExtraErrorInfo a -> IO ()
sendError DisabledYellerClient _ _ = return ()
sendError c e extra = do
let forced = seq e e
stack <- GHC.Stack.whoCreated forced
let existing = ErrorNotification {
errorType = T.pack . show $ Data.Typeable.typeOf e
, errorMessage = T.pack $ show e
, errorStackTrace = filterInAppLines (clientApplicationPackage c) (parseStackTrace stack)
, errorHost = clientHost c
, errorEnvironment = clientEnvironment c
, errorClientVersion = clientVersion c
, errorExtra = extra
}
sendNotification c $ toError e existing
sendNotification :: JSON.ToJSON a => YellerClient -> ErrorNotification a -> IO ()
sendNotification c n = sendNotificationWithRetry 0 c n (JSON.encode n)
sendNotificationWithRetry :: JSON.ToJSON a => Int -> YellerClient -> ErrorNotification a -> LBS.ByteString -> IO ()
sendNotificationWithRetry currentRetryCount c n encoded = do
currentBackend <- cycleBackends c
r <- makeRequest c currentBackend encoded
res <- Control.Exception.try $ HTTP.withResponse r (clientManager c) return
case res of
(Left (err :: Control.Exception.SomeException)) -> if currentRetryCount > clientMaxRetries c then
sendNotificationWithRetry (currentRetryCount + 1) c n encoded
else
handleIOErrors (clientErrorHandler c) err (encodeCustomDataAsJSON n)
(Right httpResponse) -> handleNonExceptionalSendRequest httpResponse currentRetryCount c n encoded
handleNonExceptionalSendRequest :: JSON.ToJSON a => HTTP.Response HTTP.BodyReader -> Int -> YellerClient -> ErrorNotification a -> LBS.ByteString -> IO ()
handleNonExceptionalSendRequest res currentRetryCount c n encoded
| status == 403 || status == 401 = handleAuthenticationErrors (clientErrorHandler c) res
| status > 299 = sendNotificationWithRetry (currentRetryCount + 1) c n encoded
| otherwise = return ()
where status = HTTPStatus.statusCode (HTTP.responseStatus res)
encodeCustomDataAsJSON :: JSON.ToJSON a => ErrorNotification a -> ErrorNotification JSON.Value
encodeCustomDataAsJSON n = n { errorExtra = (errorExtra n) { errorCustomData = Just (M.fromList [("data", JSON.toJSON (errorCustomData (errorExtra n)))]) } }
cycleBackends :: YellerClient -> IO Backend
cycleBackends c = STM.atomically $ do
modifyTVar_ (clientBackends c) cycleBackends_
head <$> STM.readTVar (clientBackends c)
cycleBackends_ :: [Backend] -> [Backend]
cycleBackends_ (x:xs) = xs ++ [x]
cycleBackends_ xs = xs
modifyTVar_ :: STM.TVar a -> (a -> a) -> STM.STM ()
modifyTVar_ tv f = STM.readTVar tv >>= STM.writeTVar tv . f
makeRequest :: YellerClient -> Backend -> LBS.ByteString -> IO HTTP.Request
makeRequest c (Backend b) n = do
initReq <- HTTP.parseUrl $ T.unpack (b <> clientToken c)
let req = initReq {
HTTP.method = "POST"
, HTTP.secure = True
, HTTP.requestBody = HTTP.RequestBodyLBS n
, HTTP.redirectCount = 0
, HTTP.requestHeaders = [("User-Agent", TE.encodeUtf8 $ clientVersion c)]
, HTTP.checkStatus = \_ _ _ -> Nothing
}
return req
client :: YellerClientSettings -> IO YellerClient
client (YellerClientSettings {clientSettingsEnvironment=TestEnvironment}) = return DisabledYellerClient
client c@(YellerClientSettings {clientSettingsEnvironment=(ApplicationEnvironment env), clientSettingsApplicationPackage=(ApplicationPackage package), clientSettingsToken=(YellerToken token)}) = do
h <- fmap T.pack Network.BSD.getHostName
m <- HTTP.newManager TLS.tlsManagerSettings
backends <- STM.newTVarIO (map Backend defaultBackends)
return YellerClient {
clientToken = token
, clientHost = h
, clientEnvironment = env
, clientVersion = yellerVersion
, clientApplicationPackage = package
, clientManager = m
, clientBackends = backends
, clientErrorHandler = clientSettingsErrorHandler c
, clientMaxRetries = clientSettingsMaxRetries c
}
shutdownClient :: YellerClient -> IO ()
shutdownClient c = HTTP.closeManager (clientManager c)