{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Honeycomb.API.Events
( Event(..)
, sendEvent
, sendBatchedEvents
, sendBatchedEvents'
, BatchResponse(..)
, BatchOptions(..)
) where
import Chronos ( timeToDatetime )
import Control.Exception
import Data.Aeson
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as L
import Control.Monad.IO.Class
import Data.Maybe
import qualified Data.Text.Encoding as T
import Data.Typeable
import Data.Vector (Vector)
import Honeycomb.Client.Internal hiding (Event)
import Honeycomb.Types
import Honeycomb.API.Types
import Network.HTTP.Simple
import Network.HTTP.Types
import Lens.Micro ( (^.), to, )
import Control.Monad.Reader (MonadReader, asks)
import Lens.Micro.Extras (view)
import Honeycomb.Config (defaultDataset, configL)
data MalformedJSONResponse = MalformedJSONResponse
{ MalformedJSONResponse -> String
malformedJSONResponseMessage :: String
, MalformedJSONResponse -> ByteString
malformedJSONResponseBody :: L.ByteString
}
deriving stock (Int -> MalformedJSONResponse -> ShowS
[MalformedJSONResponse] -> ShowS
MalformedJSONResponse -> String
(Int -> MalformedJSONResponse -> ShowS)
-> (MalformedJSONResponse -> String)
-> ([MalformedJSONResponse] -> ShowS)
-> Show MalformedJSONResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MalformedJSONResponse] -> ShowS
$cshowList :: [MalformedJSONResponse] -> ShowS
show :: MalformedJSONResponse -> String
$cshow :: MalformedJSONResponse -> String
showsPrec :: Int -> MalformedJSONResponse -> ShowS
$cshowsPrec :: Int -> MalformedJSONResponse -> ShowS
Show, Typeable)
deriving anyclass (Show MalformedJSONResponse
Typeable MalformedJSONResponse
Typeable MalformedJSONResponse
-> Show MalformedJSONResponse
-> (MalformedJSONResponse -> SomeException)
-> (SomeException -> Maybe MalformedJSONResponse)
-> (MalformedJSONResponse -> String)
-> Exception MalformedJSONResponse
SomeException -> Maybe MalformedJSONResponse
MalformedJSONResponse -> String
MalformedJSONResponse -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: MalformedJSONResponse -> String
$cdisplayException :: MalformedJSONResponse -> String
fromException :: SomeException -> Maybe MalformedJSONResponse
$cfromException :: SomeException -> Maybe MalformedJSONResponse
toException :: MalformedJSONResponse -> SomeException
$ctoException :: MalformedJSONResponse -> SomeException
$cp2Exception :: Show MalformedJSONResponse
$cp1Exception :: Typeable MalformedJSONResponse
Exception)
data FailureResponse
= UnknownApiKey
| RequestBodyTooLarge
| MalformedRequestBody
| EventDroppedDueToThrottling
| EventDroppedDueToBlacklist
| RequestDroppedDueToRateLimiting
| UnrecognizedError Status L.ByteString
deriving stock (Int -> FailureResponse -> ShowS
[FailureResponse] -> ShowS
FailureResponse -> String
(Int -> FailureResponse -> ShowS)
-> (FailureResponse -> String)
-> ([FailureResponse] -> ShowS)
-> Show FailureResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FailureResponse] -> ShowS
$cshowList :: [FailureResponse] -> ShowS
show :: FailureResponse -> String
$cshow :: FailureResponse -> String
showsPrec :: Int -> FailureResponse -> ShowS
$cshowsPrec :: Int -> FailureResponse -> ShowS
Show, Typeable)
deriving anyclass (Show FailureResponse
Typeable FailureResponse
Typeable FailureResponse
-> Show FailureResponse
-> (FailureResponse -> SomeException)
-> (SomeException -> Maybe FailureResponse)
-> (FailureResponse -> String)
-> Exception FailureResponse
SomeException -> Maybe FailureResponse
FailureResponse -> String
FailureResponse -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: FailureResponse -> String
$cdisplayException :: FailureResponse -> String
fromException :: SomeException -> Maybe FailureResponse
$cfromException :: SomeException -> Maybe FailureResponse
toException :: FailureResponse -> SomeException
$ctoException :: FailureResponse -> SomeException
$cp2Exception :: Show FailureResponse
$cp1Exception :: Typeable FailureResponse
Exception)
sendEvent :: (MonadHoneycomb client m) => Event -> m ()
sendEvent :: Event -> m ()
sendEvent Event
e = do
HoneycombClient
client <- (client -> HoneycombClient) -> m HoneycombClient
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Getting HoneycombClient client HoneycombClient
-> client -> HoneycombClient
forall a s. Getting a s a -> s -> a
view Getting HoneycombClient client HoneycombClient
forall a. HasHoneycombClient a => Lens' a HoneycombClient
honeycombClientL)
let ds :: DatasetName
ds = HoneycombClient
client HoneycombClient
-> Getting DatasetName HoneycombClient DatasetName -> DatasetName
forall s a. s -> Getting a s a -> a
^. (Config -> Const DatasetName Config)
-> HoneycombClient -> Const DatasetName HoneycombClient
forall a. HasConfig a => Lens' a Config
configL ((Config -> Const DatasetName Config)
-> HoneycombClient -> Const DatasetName HoneycombClient)
-> ((DatasetName -> Const DatasetName DatasetName)
-> Config -> Const DatasetName Config)
-> Getting DatasetName HoneycombClient DatasetName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Config -> DatasetName) -> SimpleGetter Config DatasetName
forall s a. (s -> a) -> SimpleGetter s a
to Config -> DatasetName
defaultDataset
Response ByteString
r <- (Request -> m (Response ByteString))
-> [Text] -> RequestHeaders -> Object -> m (Response ByteString)
forall (m :: * -> *) env a b.
(MonadIO m, MonadHoneycomb env m, ToJSON a) =>
(Request -> m (Response b))
-> [Text] -> RequestHeaders -> a -> m (Response b)
post Request -> m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpLBS [Text
"1", Text
"events", DatasetName -> Text
fromDatasetName DatasetName
ds] RequestHeaders
hs (Object -> m (Response ByteString))
-> Object -> m (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Event -> Object
eventData Event
e
case (Status -> Int
statusCode (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ Response ByteString -> Status
forall a. Response a -> Status
getResponseStatus Response ByteString
r, Response ByteString -> ByteString
forall a. Response a -> a
getResponseBody Response ByteString
r) of
(Int
400, ByteString
"unknown API key - check your credentials") -> FailureResponse -> m ()
forall a e. Exception e => e -> a
throw FailureResponse
UnknownApiKey
(Int
400, ByteString
"request body is too large") -> FailureResponse -> m ()
forall a e. Exception e => e -> a
throw FailureResponse
RequestBodyTooLarge
(Int
400, ByteString
"request body is malformed and cannot be read as JSON") -> FailureResponse -> m ()
forall a e. Exception e => e -> a
throw FailureResponse
MalformedRequestBody
(Int
403, ByteString
"event dropped due to administrative throttling") -> FailureResponse -> m ()
forall a e. Exception e => e -> a
throw FailureResponse
EventDroppedDueToThrottling
(Int
429, ByteString
"event dropped due to administrative blacklist") -> FailureResponse -> m ()
forall a e. Exception e => e -> a
throw FailureResponse
EventDroppedDueToBlacklist
(Int
429, ByteString
"request dropped due to rate limiting") -> FailureResponse -> m ()
forall a e. Exception e => e -> a
throw FailureResponse
RequestDroppedDueToRateLimiting
(Int
200, ByteString
_) -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
(Int
_, ByteString
str) -> FailureResponse -> m ()
forall a e. Exception e => e -> a
throw (FailureResponse -> m ()) -> FailureResponse -> m ()
forall a b. (a -> b) -> a -> b
$ Status -> ByteString -> FailureResponse
UnrecognizedError (Response ByteString -> Status
forall a. Response a -> Status
getResponseStatus Response ByteString
r) ByteString
str
where
hs :: RequestHeaders
hs = [Maybe (HeaderName, ByteString)] -> RequestHeaders
forall a. [Maybe a] -> [a]
catMaybes
[ (\Time
d -> (HeaderName
"X-Honeycomb-Event-Time", Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Datetime -> Text
encodeRFC3339 (Datetime -> Text) -> Datetime -> Text
forall a b. (a -> b) -> a -> b
$ Time -> Datetime
timeToDatetime Time
d)) (Time -> (HeaderName, ByteString))
-> Maybe Time -> Maybe (HeaderName, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event -> Maybe Time
eventTimestamp Event
e
, (\Word64
r -> (HeaderName
"X-Honeycomb-Samplerate", String -> ByteString
C.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Word64 -> String
forall a. Show a => a -> String
show Word64
r)) (Word64 -> (HeaderName, ByteString))
-> Maybe Word64 -> Maybe (HeaderName, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event -> Maybe Word64
eventSampleRate Event
e
]
newtype BatchOptions = BatchOptions
{ BatchOptions -> Bool
useGZip :: Bool
} deriving (Int -> BatchOptions -> ShowS
[BatchOptions] -> ShowS
BatchOptions -> String
(Int -> BatchOptions -> ShowS)
-> (BatchOptions -> String)
-> ([BatchOptions] -> ShowS)
-> Show BatchOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BatchOptions] -> ShowS
$cshowList :: [BatchOptions] -> ShowS
show :: BatchOptions -> String
$cshow :: BatchOptions -> String
showsPrec :: Int -> BatchOptions -> ShowS
$cshowsPrec :: Int -> BatchOptions -> ShowS
Show, ReadPrec [BatchOptions]
ReadPrec BatchOptions
Int -> ReadS BatchOptions
ReadS [BatchOptions]
(Int -> ReadS BatchOptions)
-> ReadS [BatchOptions]
-> ReadPrec BatchOptions
-> ReadPrec [BatchOptions]
-> Read BatchOptions
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [BatchOptions]
$creadListPrec :: ReadPrec [BatchOptions]
readPrec :: ReadPrec BatchOptions
$creadPrec :: ReadPrec BatchOptions
readList :: ReadS [BatchOptions]
$creadList :: ReadS [BatchOptions]
readsPrec :: Int -> ReadS BatchOptions
$creadsPrec :: Int -> ReadS BatchOptions
Read)
sendBatchedEvents :: (MonadHoneycomb client m) => Vector Event -> m (Vector BatchResponse)
sendBatchedEvents :: Vector Event -> m (Vector BatchResponse)
sendBatchedEvents = BatchOptions -> Vector Event -> m (Vector BatchResponse)
forall client (m :: * -> *).
MonadHoneycomb client m =>
BatchOptions -> Vector Event -> m (Vector BatchResponse)
sendBatchedEvents' (Bool -> BatchOptions
BatchOptions Bool
False)
newtype BatchResponse = BatchResponse { BatchResponse -> Int
batchResponseStatus :: Int }
deriving (Int -> BatchResponse -> ShowS
[BatchResponse] -> ShowS
BatchResponse -> String
(Int -> BatchResponse -> ShowS)
-> (BatchResponse -> String)
-> ([BatchResponse] -> ShowS)
-> Show BatchResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BatchResponse] -> ShowS
$cshowList :: [BatchResponse] -> ShowS
show :: BatchResponse -> String
$cshow :: BatchResponse -> String
showsPrec :: Int -> BatchResponse -> ShowS
$cshowsPrec :: Int -> BatchResponse -> ShowS
Show)
instance FromJSON BatchResponse where
parseJSON :: Value -> Parser BatchResponse
parseJSON = String
-> (Object -> Parser BatchResponse)
-> Value
-> Parser BatchResponse
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"BatchResponse" ((Object -> Parser BatchResponse) -> Value -> Parser BatchResponse)
-> (Object -> Parser BatchResponse)
-> Value
-> Parser BatchResponse
forall a b. (a -> b) -> a -> b
$ \Object
o -> Int -> BatchResponse
BatchResponse (Int -> BatchResponse) -> Parser Int -> Parser BatchResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"status")
sendBatchedEvents' :: (MonadHoneycomb client m) => BatchOptions -> Vector Event -> m (Vector BatchResponse)
sendBatchedEvents' :: BatchOptions -> Vector Event -> m (Vector BatchResponse)
sendBatchedEvents' BatchOptions
_ Vector Event
events = do
Config
config <- (client -> Config) -> m Config
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Getting Config client Config -> client -> Config
forall a s. Getting a s a -> s -> a
view ((HoneycombClient -> Const Config HoneycombClient)
-> client -> Const Config client
forall a. HasHoneycombClient a => Lens' a HoneycombClient
honeycombClientL ((HoneycombClient -> Const Config HoneycombClient)
-> client -> Const Config client)
-> ((Config -> Const Config Config)
-> HoneycombClient -> Const Config HoneycombClient)
-> Getting Config client Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Config -> Const Config Config)
-> HoneycombClient -> Const Config HoneycombClient
forall a. HasConfig a => Lens' a Config
configL))
let ds :: DatasetName
ds = Config -> DatasetName
defaultDataset Config
config
Response ByteString
r <- (Request -> m (Response ByteString))
-> [Text]
-> RequestHeaders
-> Vector Event
-> m (Response ByteString)
forall (m :: * -> *) env a b.
(MonadIO m, MonadHoneycomb env m, ToJSON a) =>
(Request -> m (Response b))
-> [Text] -> RequestHeaders -> a -> m (Response b)
post Request -> m (Response ByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpLBS [Text
"1", Text
"batch", DatasetName -> Text
fromDatasetName DatasetName
ds] [] Vector Event
events
case Response (Either String (Vector BatchResponse))
-> Either String (Vector BatchResponse)
forall a. Response a -> a
getResponseBody (Response (Either String (Vector BatchResponse))
-> Either String (Vector BatchResponse))
-> Response (Either String (Vector BatchResponse))
-> Either String (Vector BatchResponse)
forall a b. (a -> b) -> a -> b
$ Response ByteString
-> Response (Either String (Vector BatchResponse))
forall a.
FromJSON a =>
Response ByteString -> Response (Either String a)
decodeJSON Response ByteString
r of
Left String
err -> MalformedJSONResponse -> m (Vector BatchResponse)
forall a e. Exception e => e -> a
throw (MalformedJSONResponse -> m (Vector BatchResponse))
-> MalformedJSONResponse -> m (Vector BatchResponse)
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> MalformedJSONResponse
MalformedJSONResponse String
err (Response ByteString -> ByteString
forall a. Response a -> a
getResponseBody Response ByteString
r)
Right Vector BatchResponse
ok -> Vector BatchResponse -> m (Vector BatchResponse)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Vector BatchResponse
ok