{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE QuantifiedConstraints #-}
module Honeycomb.Client.Internal where

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

data HoneycombClient = HoneycombClient
  { HoneycombClient -> Config
clientConfig :: Config
  , HoneycombClient -> GenIO
clientGen :: GenIO
  -- | 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.
  , HoneycombClient -> TBQueue (IO ())
clientEventBuffer :: TBQueue (IO ())
  -- , clientQueueMap :: Map ThreadId 
  , HoneycombClient -> [Async ()]
clientWorkers :: [Async ()]
  }

class HasHoneycombClient a where
  honeycombClientL :: Lens' a HoneycombClient

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

instance HasConfig HoneycombClient where
  configL :: (Config -> f Config) -> HoneycombClient -> f HoneycombClient
configL = (HoneycombClient -> Config)
-> (HoneycombClient -> Config -> HoneycombClient)
-> Lens' HoneycombClient Config
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)

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
  }


post :: (MonadIO m, MonadHoneycomb env m, ToJSON a) => (Request -> m (Response b)) -> [Text] -> RequestHeaders -> a -> m (Response b)
post :: (Request -> m (Response b))
-> [Text] -> RequestHeaders -> a -> m (Response b)
post Request -> m (Response b)
f [Text]
pathPieces RequestHeaders
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
..} <- (env -> Config) -> m Config
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Getting Config env Config -> env -> Config
forall a s. Getting a s a -> s -> a
view ((HoneycombClient -> Const Config HoneycombClient)
-> env -> Const Config env
forall a. HasHoneycombClient a => Lens' a HoneycombClient
honeycombClientL ((HoneycombClient -> Const Config HoneycombClient)
 -> env -> Const Config env)
-> ((Config -> Const Config Config)
    -> HoneycombClient -> Const Config HoneycombClient)
-> Getting Config env 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 req :: Request
req = Request
defaultRequest 
        { method :: ByteString
method = ByteString
methodPost
        , host :: ByteString
host = ByteString
"api.honeycomb.io"
        , port :: Int
port = Int
443
        , path :: ByteString
path = Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"/" [Text]
pathPieces
        , secure :: Bool
secure = Bool
True
        , requestHeaders :: RequestHeaders
requestHeaders = RequestHeaders
hs RequestHeaders -> RequestHeaders -> RequestHeaders
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
teamWritekey)
            ]
        -- TODO
        , requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS (ByteString -> RequestBody) -> ByteString -> RequestBody
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. ToJSON a => a -> ByteString
encode a
x
        }
  Request -> m (Response b)
f Request
req

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

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

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

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