diff --git a/honeycomb.cabal b/honeycomb.cabal --- a/honeycomb.cabal +++ b/honeycomb.cabal @@ -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 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 diff --git a/src/Honeycomb.hs b/src/Honeycomb.hs --- a/src/Honeycomb.hs +++ b/src/Honeycomb.hs @@ -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 diff --git a/src/Honeycomb/API/Auth.hs b/src/Honeycomb/API/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Honeycomb/API/Auth.hs @@ -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) diff --git a/src/Honeycomb/API/Auth/Types.hs b/src/Honeycomb/API/Auth/Types.hs new file mode 100644 --- /dev/null +++ b/src/Honeycomb/API/Auth/Types.hs @@ -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) diff --git a/src/Honeycomb/Aeson.hs b/src/Honeycomb/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Honeycomb/Aeson.hs @@ -0,0 +1,11 @@ +module Honeycomb.Aeson (snakeCaseOptions) where +import Data.Aeson + +snakeCaseOptions :: Options +snakeCaseOptions = + defaultOptions + { fieldLabelModifier = camelTo2 '_' + , constructorTagModifier = camelTo2 '_' + } + + diff --git a/src/Honeycomb/Client/Internal.hs b/src/Honeycomb/Client/Internal.hs --- a/src/Honeycomb/Client/Internal.hs +++ b/src/Honeycomb/Client/Internal.hs @@ -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 diff --git a/src/Honeycomb/Config.hs b/src/Honeycomb/Config.hs --- a/src/Honeycomb/Config.hs +++ b/src/Honeycomb/Config.hs