{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleInstances #-}

module Honeycomb.Client.Internal where

import Chronos
import Control.Concurrent.Async
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Reader.Class
import Data.Aeson (FromJSON, ToJSON, Value, eitherDecode, encode)
import qualified Data.ByteString.Lazy as L
import Data.HashMap.Strict as S
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Vector (Vector)
import Data.Word (Word64)
import Honeycomb.Config
import qualified Honeycomb.Config as Config
import Honeycomb.Types
import Lens.Micro
import Lens.Micro.Extras
import Network.HTTP.Client
import Network.HTTP.Types
import System.Random.MWC
import UnliftIO.STM (TBQueue)

data HoneycombClient = HoneycombClient
  { HoneycombClient -> Config
clientConfig :: Config
  , HoneycombClient -> GenIO
clientGen :: GenIO
  , HoneycombClient -> TBQueue (IO ())
clientEventBuffer :: TBQueue (IO ())
  -- ^ Subject to change
  -- TODO this respects dispatching to custom host/dataset/writekey/etc, but needs a means of
  -- using the bulk events API instead of dispatching a bunch of single event calls.
  , -- , clientQueueMap :: Map ThreadId
    HoneycombClient -> [Async ()]
clientWorkers :: [Async ()]
  }

class HasConfig a => HasHoneycombClient a where
  honeycombClientL :: Lens' a HoneycombClient

instance HasHoneycombClient HoneycombClient where
  honeycombClientL :: Lens' HoneycombClient HoneycombClient
honeycombClientL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall a. a -> a
id (\HoneycombClient
_ HoneycombClient
new -> HoneycombClient
new)

instance HasConfig HoneycombClient where
  configL :: Lens' HoneycombClient Config
configL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens HoneycombClient -> Config
clientConfig (\HoneycombClient
c Config
conf -> HoneycombClient
c {clientConfig :: Config
clientConfig = Config
conf})

type MonadHoneycomb env m = (MonadIO m, HasHoneycombClient env, MonadReader env m)

-- | Weaker version of 'MonadHoneycomb' which only provides a config. Useful for
--   just doing HTTP requests without using the events sender.
type MonadHoneycombConfig env m = (HasConfig env, MonadReader env m)

data Event = Event
  { Event -> HashMap Text Value
fields :: S.HashMap Text Value
  , Event -> Maybe Text
teamWriteKey :: Maybe Text
  , Event -> Maybe DatasetName
dataset :: Maybe DatasetName
  , Event -> Maybe Text
apiHost :: Maybe Text
  , Event -> Maybe Word64
sampleRate :: Maybe Word64
  , Event -> Maybe Time
timestamp :: Maybe Time
  }

defaultHoneycombRequest :: Text -> [Text] -> [Header] -> Text -> Request
defaultHoneycombRequest :: Text -> [Text] -> [Header] -> Text -> Request
defaultHoneycombRequest Text
apiHost [Text]
pathPieces [Header]
hs Text
key =
  Request
defaultRequest
    { host :: ByteString
host = Text -> ByteString
T.encodeUtf8 Text
apiHost
    , port :: Int
port = Int
443
    , path :: ByteString
path = Text -> ByteString
T.encodeUtf8 forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"/" [Text]
pathPieces
    , secure :: Bool
secure = Bool
True
    , requestHeaders :: [Header]
requestHeaders =
        [Header]
hs
          forall a. [a] -> [a] -> [a]
++ [ (HeaderName
hUserAgent, ByteString
"libhoneycomb-haskell/0.0.0.1")
             , (HeaderName
hContentType, ByteString
"application/json")
             , (HeaderName
"X-Honeycomb-Team", Text -> ByteString
T.encodeUtf8 Text
key)
             ]
    }

post :: (MonadIO m, MonadHoneycombConfig env m, ToJSON a) => (Request -> m (Response b)) -> [Text] -> RequestHeaders -> a -> m (Response b)
post :: forall (m :: * -> *) env a b.
(MonadIO m, MonadHoneycombConfig env m, ToJSON a) =>
(Request -> m (Response b))
-> [Text] -> [Header] -> a -> m (Response b)
post Request -> m (Response b)
f [Text]
pathPieces [Header]
hs a
x = do
  Config {Bool
Maybe Word64
Word64
ByteString
Text
DatasetName
customUserAgent :: Config -> ByteString
nullTransmission :: Config -> Bool
sendBlocking :: Config -> Bool
sendThreads :: Config -> Word64
pendingQueueSize :: Config -> Word64
sampleRate :: Config -> Maybe Word64
apiHost :: Config -> Text
defaultDataset :: Config -> DatasetName
teamWritekey :: Config -> Text
customUserAgent :: ByteString
nullTransmission :: Bool
sendBlocking :: Bool
sendThreads :: Word64
pendingQueueSize :: Word64
sampleRate :: Maybe Word64
apiHost :: Text
defaultDataset :: DatasetName
teamWritekey :: Text
..} <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a s. Getting a s a -> s -> a
view forall a. HasConfig a => Lens' a Config
configL)
  let req :: Request
req =
        (Text -> [Text] -> [Header] -> Text -> Request
defaultHoneycombRequest Text
apiHost [Text]
pathPieces [Header]
hs Text
teamWritekey)
          { method :: ByteString
method = ByteString
methodPost
          , -- TODO
            requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encode a
x
          }
  Request -> m (Response b)
f Request
req

get :: (MonadIO m, MonadHoneycombConfig env m, HasConfig env) => (Request -> m (Response b)) -> [Text] -> RequestHeaders -> m (Response b)
get :: forall (m :: * -> *) env b.
(MonadIO m, MonadHoneycombConfig env m, HasConfig env) =>
(Request -> m (Response b)) -> [Text] -> [Header] -> m (Response b)
get Request -> m (Response b)
f [Text]
pathPieces [Header]
hs = do
  Config {Bool
Maybe Word64
Word64
ByteString
Text
DatasetName
customUserAgent :: ByteString
nullTransmission :: Bool
sendBlocking :: Bool
sendThreads :: Word64
pendingQueueSize :: Word64
sampleRate :: Maybe Word64
apiHost :: Text
defaultDataset :: DatasetName
teamWritekey :: Text
customUserAgent :: Config -> ByteString
nullTransmission :: Config -> Bool
sendBlocking :: Config -> Bool
sendThreads :: Config -> Word64
pendingQueueSize :: Config -> Word64
sampleRate :: Config -> Maybe Word64
apiHost :: Config -> Text
defaultDataset :: Config -> DatasetName
teamWritekey :: Config -> Text
..} <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a s. Getting a s a -> s -> a
view forall a. HasConfig a => Lens' a Config
configL)
  let req :: Request
req =
        (Text -> [Text] -> [Header] -> Text -> Request
defaultHoneycombRequest Text
apiHost [Text]
pathPieces [Header]
hs Text
teamWritekey)
          { method :: ByteString
method = ByteString
methodGet
          }
  Request -> m (Response b)
f Request
req

put :: (MonadIO m, MonadHoneycomb env m, FromJSON a) => (Request -> m (Response b)) -> [Text] -> [(Text, Text)] -> m a
put :: forall (m :: * -> *) env a b.
(MonadIO m, MonadHoneycomb env m, FromJSON a) =>
(Request -> m (Response b)) -> [Text] -> [(Text, Text)] -> m a
put = forall a. HasCallStack => a
undefined

delete :: (MonadIO m, MonadHoneycomb env m, FromJSON a) => (Request -> m (Response b)) -> [Text] -> [(Text, Text)] -> m a
delete :: forall (m :: * -> *) env a b.
(MonadIO m, MonadHoneycomb env m, FromJSON a) =>
(Request -> m (Response b)) -> [Text] -> [(Text, Text)] -> m a
delete = forall a. HasCallStack => a
undefined

decodeJSON :: FromJSON a => Response L.ByteString -> Response (Either String a)
decodeJSON :: forall a.
FromJSON a =>
Response ByteString -> Response (Either String a)
decodeJSON = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. FromJSON a => ByteString -> Either String a
eitherDecode