{-# 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
      ]

{-
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
(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