honeycomb 0.0.0.3 → 0.1.0.0

raw patch · 7 files changed

+182/−49 lines, 7 filesdep ~aesonPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson

API changes (from Hackage documentation)

Files

• honeycomb.cabal +10/−7
• src/Honeycomb.hs +3/−2
• src/Honeycomb/API/Auth.hs +25/−0
• src/Honeycomb/API/Auth/Types.hs +75/−0
• src/Honeycomb/Aeson.hs +11/−0
• src/Honeycomb/Client/Internal.hs +58/−40
• src/Honeycomb/Config.hs +0/−0

@@ -1,19 +1,19 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.34.7. -- -- see: https://github.com/sol/hpack ----- hash: 71e86a9d866e470b3be18e84cf0f065d7cd0e6d870980972dc38f8eb2488fd6a+-- hash: 2a670d8927ccbe14b8715231c27dedb4b077025fdc2dd914a06603979fa1a011  name:           honeycomb-version:        0.0.0.3+version:        0.1.0.0 description:    Please see the README on GitHub at <https://github.com/githubuser/honeycomb#readme> homepage:       https://github.com/iand675/hs-honeycomb#readme bug-reports:    https://github.com/iand675/hs-honeycomb/issues-author:         Ian Duncan+author:         Ian Duncan, Jade Lovelace maintainer:     ian@iankduncan.com-copyright:      2021 Ian Duncan+copyright:      2021 Ian Duncan, 2022 Mercury Technologies, Inc license:        BSD3 license-file:   LICENSE build-type:     Simple@@ -31,9 +31,12 @@       Honeycomb.API.Events       Honeycomb.API.Markers       Honeycomb.API.Types+      Honeycomb.API.Auth       Honeycomb.Config       Honeycomb.Types   other-modules:+      Honeycomb.Aeson+      Honeycomb.API.Auth.Types       Honeycomb.API.Boards       Honeycomb.API.Columns       Honeycomb.API.Datasets@@ -51,7 +54,7 @@       OverloadedStrings       RecordWildCards   build-depends:-      aeson+      aeson >=2.0     , async     , auto-update     , base >=4.7 && <5@@ -92,7 +95,7 @@       RecordWildCards   ghc-options: -threaded -rtsopts -with-rtsopts=-N   build-depends:-      aeson+      aeson >=2.0     , async     , auto-update     , base >=4.7 && <5

@@ -11,7 +11,7 @@ Warning, not all configuration options actually do what they claim yet. -} module Honeycomb-  ( +  (   -- * Initializing and shutting down a 'HoneycombClient'     HoneycombClient   , initializeHoneycomb@@ -46,6 +46,7 @@ import Control.Concurrent import Lens.Micro ((%~), (^.), (&)) import Lens.Micro.Extras (view)+import qualified Data.Aeson.KeyMap as KeyMap  initializeHoneycomb :: MonadIO m => Config.Config -> m HoneycombClient initializeHoneycomb conf = liftIO $ do@@ -99,7 +100,7 @@       x <- uniformR (1, n) clientGen       pure (1 == x, x)   when shouldSend $ do-    let event_ = API.Event specifiedSampleRate (timestamp e) (fields e)+    let event_ = API.Event specifiedSampleRate (timestamp e) (KeyMap.fromHashMapText $ fields e)         localOptions = honeycombClientL %~ (\c -> c { clientConfig = replaceDataset $ replaceHost $ replaceWriteKey clientConfig })         blockingEvent = runReaderT (API.sendEvent event_) (c & localOptions)     liftIO $ if Config.sendBlocking clientConfig

@@ -0,0 +1,25 @@+module Honeycomb.API.Auth (module Honeycomb.API.Auth.Types, getAuth) where++import Control.Exception (throwIO)+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Reader.Class (asks)+import Data.Aeson (eitherDecode)+import qualified Data.Text as T+import Honeycomb+  ( HasHoneycombClient (honeycombClientL),+    MonadHoneycomb,+  )+import Honeycomb.API.Auth.Types+import Honeycomb.Client.Internal (MonadHoneycombConfig, get)+import Lens.Micro.Extras (view)+import Network.HTTP.Client (Response (responseBody))+import Network.HTTP.Simple (getResponseBody, getResponseStatusCode, httpLBS)++getAuth :: (MonadIO m, MonadHoneycombConfig client m) => m Auth+getAuth = do+  r <- get httpLBS ["1", "auth"] []+  case getResponseStatusCode r of+    200 -> case eitherDecode (responseBody r) of+      Right r -> pure r+      Left r -> liftIO . throwIO . JsonDecodeFailed . T.pack $ r+    other -> liftIO . throwIO $ FailureCode other (getResponseBody r)

@@ -0,0 +1,75 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE TemplateHaskell #-}++module Honeycomb.API.Auth.Types where++import Control.Exception+import Data.Aeson.TH (defaultOptions, deriveFromJSON)+import Data.ByteString (ByteString)+import Data.ByteString.Lazy (LazyByteString)+import Data.Text (Text)+import Honeycomb.Aeson (snakeCaseOptions)++data NameAndSlug = NameAndSlug+  { name :: Text+  , slug :: Text+  }+  deriving stock (Show, Eq)++$(deriveFromJSON snakeCaseOptions ''NameAndSlug)++data ApiKeyAccess = ApiKeyAccess+  { events :: Bool+  , markers :: Bool+  , triggers :: Bool+  , boards :: Bool+  , queries :: Bool+  , columns :: Bool+  , createDatasets :: Bool+  , slos :: Bool+  , recipients :: Bool+  , privateBoards :: Bool+  }+  deriving stock (Show, Eq)++-- XXX: yes, this is intentionally defaultOptions, because for some reason the+-- API is generally snake case but the "createDatasets" is camel case+$(deriveFromJSON defaultOptions ''ApiKeyAccess)++-- | Response to the auth API+--  @+--  {+--    "api_key_access": {+--      "events": true,+--      "markers": true,+--      "triggers": true,+--      "boards": true,+--      "queries": true,+--      "columns": false,+--      "createDatasets": true+--    },+--    "environment": {+--      "name": "Production",+--      "slug": "production"+--    },+--    "team": {+--      "name": "Honeycomb Docs",+--      "slug": "honeycomb-docs"+--    }+--  }+--  @+data Auth = Auth+  { apiKeyAccess :: ApiKeyAccess+  , environment :: NameAndSlug+  , team :: NameAndSlug+  }+  deriving stock (Show, Eq)++$(deriveFromJSON snakeCaseOptions ''Auth)++data FailureResponse+  = FailureCode Int LazyByteString+  | JsonDecodeFailed Text+  deriving stock (Show)+  deriving anyclass (Exception)

@@ -0,0 +1,11 @@+module Honeycomb.Aeson (snakeCaseOptions) where+import Data.Aeson++snakeCaseOptions :: Options+snakeCaseOptions =+  defaultOptions+    { fieldLabelModifier = camelTo2 '_'+    , constructorTagModifier = camelTo2 '_'+    }++

@@ -1,55 +1,61 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE DataKinds #-} {-# 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 Data.Aeson (Value, ToJSON, FromJSON, eitherDecode, encode)+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 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+import Network.HTTP.Client+import Network.HTTP.Types+import System.Random.MWC+import UnliftIO.STM (TBQueue)  data HoneycombClient = HoneycombClient   { clientConfig :: Config   , clientGen :: GenIO-  -- | Subject to change+  , 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.-  , clientEventBuffer :: TBQueue (IO ())-  -- , clientQueueMap :: Map ThreadId -  , clientWorkers :: [Async ()]+  , -- , clientQueueMap :: Map ThreadId+    clientWorkers :: [Async ()]   } -class HasHoneycombClient a where+class HasConfig a => HasHoneycombClient a where   honeycombClientL :: Lens' a HoneycombClient  instance HasHoneycombClient HoneycombClient where   honeycombClientL = lens id (\_ new -> new)  instance HasConfig HoneycombClient where-  configL = lens clientConfig (\c conf -> c { clientConfig = conf })+  configL = lens clientConfig (\c conf -> c {clientConfig = 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   { fields :: S.HashMap Text Value   , teamWriteKey :: Maybe Text@@ -59,28 +65,40 @@   , timestamp :: Maybe Time   } +defaultHoneycombRequest :: Text -> [Text] -> [Header] -> Text -> Request+defaultHoneycombRequest apiHost pathPieces hs key =+  defaultRequest+    { host = T.encodeUtf8 apiHost+    , port = 443+    , path = T.encodeUtf8 $ T.intercalate "/" pathPieces+    , secure = True+    , requestHeaders =+        hs+          ++ [ (hUserAgent, "libhoneycomb-haskell/0.0.0.1")+             , (hContentType, "application/json")+             , ("X-Honeycomb-Team", T.encodeUtf8 key)+             ]+    } -post :: (MonadIO m, MonadHoneycomb env m, ToJSON a) => (Request -> m (Response b)) -> [Text] -> RequestHeaders -> a -> m (Response b)+post :: (MonadIO m, MonadHoneycombConfig env m, ToJSON a) => (Request -> m (Response b)) -> [Text] -> RequestHeaders -> a -> m (Response b) post f pathPieces hs x = do-  Config{..} <- asks (view (honeycombClientL . configL))-  let req = defaultRequest -        { method = methodPost-        , host = "api.honeycomb.io"-        , port = 443-        , path = T.encodeUtf8 $ T.intercalate "/" pathPieces-        , secure = True-        , requestHeaders = hs ++-            [ (hUserAgent, "libhoneycomb-haskell/0.0.0.1")-            , (hContentType, "application/json")-            , ("X-Honeycomb-Team", T.encodeUtf8 teamWritekey)-            ]-        -- TODO-        , requestBody = RequestBodyLBS $ encode x-        }+  Config {..} <- asks (view configL)+  let req =+        (defaultHoneycombRequest apiHost pathPieces hs teamWritekey)+          { method = methodPost+          , -- TODO+            requestBody = RequestBodyLBS $ encode x+          }   f req -get :: (MonadIO m, MonadHoneycomb env m, FromJSON a) => (Request -> m (Response b)) -> [Text] -> [(Text, Text)] -> m a-get = undefined+get :: (MonadIO m, MonadHoneycombConfig env m, HasConfig env) => (Request -> m (Response b)) -> [Text] -> RequestHeaders -> m (Response b)+get f pathPieces hs = do+  Config {..} <- asks (view configL)+  let req =+        (defaultHoneycombRequest apiHost pathPieces hs teamWritekey)+          { method = methodGet+          }+  f req  put :: (MonadIO m, MonadHoneycomb env m, FromJSON a) => (Request -> m (Response b)) -> [Text] -> [(Text, Text)] -> m a put = undefined