{-# 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
, HoneycombClient -> TBQueue (IO ())
clientEventBuffer :: TBQueue (IO ())
, 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)
]
, 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