{-# 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
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
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
Exception)

data FailureResponse
  = UnknownApiKey
  | RequestBodyTooLarge
  | MalformedRequestBody
  | EventDroppedDueToThrottling
  | EventDroppedDueToBlacklist
  | RequestDroppedDueToRateLimiting
  | UnrecognizedError Status L.ByteString 
  deriving stock (Int -> FailureResponse -> ShowS
[FailureResponse] -> ShowS
FailureResponse -> String
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
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
Exception)

sendEvent :: (MonadHoneycomb client m) => Event -> m ()
sendEvent :: forall client (m :: * -> *).
MonadHoneycomb client m =>
Event -> m ()
sendEvent Event
e = do
  HoneycombClient
client <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a s. Getting a s a -> s -> a
view forall a. HasHoneycombClient a => Lens' a HoneycombClient
honeycombClientL)
  let ds :: DatasetName
ds = HoneycombClient
client forall s a. s -> Getting a s a -> a
^. forall a. HasConfig a => Lens' a Config
configL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to Config -> DatasetName
defaultDataset
  Response ByteString
r <- forall (m :: * -> *) env a b.
(MonadIO m, MonadHoneycombConfig env m, ToJSON a) =>
(Request -> m (Response b))
-> [Text] -> RequestHeaders -> a -> m (Response b)
post forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpLBS [Text
"1", Text
"events", DatasetName -> Text
fromDatasetName DatasetName
ds] RequestHeaders
hs forall a b. (a -> b) -> a -> b
$ Event -> Object
eventData Event
e
  case (Status -> Int
statusCode forall a b. (a -> b) -> a -> b
$ forall a. Response a -> Status
getResponseStatus Response ByteString
r, forall a. Response a -> a
getResponseBody Response ByteString
r) of
    (Int
400, ByteString
"unknown API key - check your credentials") -> forall a e. Exception e => e -> a
throw FailureResponse
UnknownApiKey
    (Int
400, ByteString
"request body is too large") -> forall a e. Exception e => e -> a
throw FailureResponse
RequestBodyTooLarge
    (Int
400, ByteString
"request body is malformed and cannot be read as JSON") -> forall a e. Exception e => e -> a
throw FailureResponse
MalformedRequestBody
    (Int
403, ByteString
"event dropped due to administrative throttling") -> forall a e. Exception e => e -> a
throw FailureResponse
EventDroppedDueToThrottling
    (Int
429, ByteString
"event dropped due to administrative blacklist") -> forall a e. Exception e => e -> a
throw FailureResponse
EventDroppedDueToBlacklist
    (Int
429, ByteString
"request dropped due to rate limiting") -> forall a e. Exception e => e -> a
throw FailureResponse
RequestDroppedDueToRateLimiting
    (Int
200, ByteString
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    (Int
_, ByteString
str) -> forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$ Status -> ByteString -> FailureResponse
UnrecognizedError (forall a. Response a -> Status
getResponseStatus Response ByteString
r) ByteString
str
  where
    hs :: RequestHeaders
hs = forall a. [Maybe a] -> [a]
catMaybes
      [ (\Time
d -> (HeaderName
"X-Honeycomb-Event-Time", Text -> ByteString
T.encodeUtf8 forall a b. (a -> b) -> a -> b
$ Datetime -> Text
encodeRFC3339 forall a b. (a -> b) -> a -> b
$ Time -> Datetime
timeToDatetime Time
d)) 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 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Word64
r)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event -> Maybe Word64
eventSampleRate Event
e
      ]

{-
There are a few limits to note in regards to the events API:

Requests to the individual event endpoint have a maximum request body size of 100KB.
Requests to the batched events endpoint have a maximum request body size of 5MB. Individual event bodies in the batch are limited to 100KB each.
The maximum number of distinct columns (fields) allowed per event is 2000.

Size limitations may be addressed by gzipping request bodies. Be sure to set the Content-Encoding: gzip
-}
newtype BatchOptions = BatchOptions 
  { BatchOptions -> Bool
useGZip :: Bool
  } deriving (Int -> BatchOptions -> ShowS
[BatchOptions] -> ShowS
BatchOptions -> String
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]
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 :: forall client (m :: * -> *).
MonadHoneycomb client m =>
Vector Event -> m (Vector BatchResponse)
sendBatchedEvents = 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
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 = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"BatchResponse" forall a b. (a -> b) -> a -> b
$ \Object
o -> Int -> BatchResponse
BatchResponse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"status")

sendBatchedEvents' :: (MonadHoneycomb client m) => BatchOptions -> Vector Event -> m (Vector BatchResponse)
sendBatchedEvents' :: forall client (m :: * -> *).
MonadHoneycomb client m =>
BatchOptions -> Vector Event -> m (Vector BatchResponse)
sendBatchedEvents' BatchOptions
_ Vector Event
events = do
  Config
config <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a s. Getting a s a -> s -> a
view (forall a. HasHoneycombClient a => Lens' a HoneycombClient
honeycombClientL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasConfig a => Lens' a Config
configL))
  let ds :: DatasetName
ds = Config -> DatasetName
defaultDataset Config
config
  Response ByteString
r <- forall (m :: * -> *) env a b.
(MonadIO m, MonadHoneycombConfig env m, ToJSON a) =>
(Request -> m (Response b))
-> [Text] -> RequestHeaders -> a -> m (Response b)
post forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
httpLBS [Text
"1", Text
"batch", DatasetName -> Text
fromDatasetName DatasetName
ds] [] Vector Event
events
  case forall a. Response a -> a
getResponseBody forall a b. (a -> b) -> a -> b
$ forall a.
FromJSON a =>
Response ByteString -> Response (Either String a)
decodeJSON Response ByteString
r of
    Left String
err -> forall a e. Exception e => e -> a
throw forall a b. (a -> b) -> a -> b
$ String -> ByteString -> MalformedJSONResponse
MalformedJSONResponse String
err (forall a. Response a -> a
getResponseBody Response ByteString
r)
    Right Vector BatchResponse
ok -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Vector BatchResponse
ok