diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for honeycomb + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2021 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +# honeycomb + +> :warning: **Very early stage project**: Minimal functionality or API stability guarantees! + +A Honeycomb client library for Haskell. This client aims to provide the full breadth of the Honeycomb +APIs, as well as a simple client for sending events, which is what most people will probably want to do. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/honeycomb.cabal b/honeycomb.cabal new file mode 100644 --- /dev/null +++ b/honeycomb.cabal @@ -0,0 +1,121 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 115fa0a891f3393b044e03e6e67833b04927d32273358d4134500d966e843829 + +name: honeycomb +version: 0.0.0.1 +description: Please see the README on GitHub at +homepage: https://github.com/githubuser/honeycomb#readme +bug-reports: https://github.com/githubuser/honeycomb/issues +author: Author name here +maintainer: example@example.com +copyright: 2021 Author name here +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/githubuser/honeycomb + +library + exposed-modules: + Honeycomb + Honeycomb.API.Events + Honeycomb.API.Markers + Honeycomb.API.Types + Honeycomb.Config + Honeycomb.Types + other-modules: + Honeycomb.API.Boards + Honeycomb.API.Columns + Honeycomb.API.Datasets + Honeycomb.API.DerivedColumns + Honeycomb.API.Queries + Honeycomb.API.QueryAnnotations + Honeycomb.API.Triggers + Honeycomb.Client.Internal + Paths_honeycomb + hs-source-dirs: + src + default-extensions: + GADTs + GeneralizedNewtypeDeriving + OverloadedStrings + RecordWildCards + build-depends: + aeson + , async + , auto-update + , base >=4.7 && <5 + , bytestring + , chronos + , http-client + , http-client-tls + , http-conduit + , http-types + , microlens + , mmorph + , monad-control + , mtl + , mwc-random + , profunctors + , random >=1.2 + , resource-pool + , stm + , text + , unliftio + , unordered-containers + , uuid + , vector + , zlib + default-language: Haskell2010 + +test-suite honeycomb-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_honeycomb + hs-source-dirs: + test + default-extensions: + GADTs + GeneralizedNewtypeDeriving + OverloadedStrings + RecordWildCards + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , async + , auto-update + , base >=4.7 && <5 + , bytestring + , chronos + , honeycomb + , http-client + , http-client-tls + , http-conduit + , http-types + , microlens + , mmorph + , monad-control + , mtl + , mwc-random + , profunctors + , random >=1.2 + , resource-pool + , stm + , text + , unliftio + , unordered-containers + , uuid + , vector + , zlib + default-language: Haskell2010 diff --git a/src/Honeycomb.hs b/src/Honeycomb.hs new file mode 100644 --- /dev/null +++ b/src/Honeycomb.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE RecordWildCards #-} +{-| +Module : Honeycomb +Description : A simple interface to send events to Honeycomb. +Copyright : (c) Ian Duncan, 2021 +License : BSD-3 +Maintainer : ian@iankduncan.com +Stability : unstable +Portability : Portable + +Warning, not all configuration options actually do what they claim yet. +-} +module Honeycomb + ( + -- * Initializing and shutting down a 'HoneycombClient' + HoneycombClient + , initializeHoneycomb + , Config.config + , shutdownHoneycomb + -- * Sending events + , event + , Event(..) + , send + -- * Embedding a HoneycombClient into larger applications + , MonadHoneycomb + , HasHoneycombClient(..) + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +import Data.HashMap.Strict as S +import Data.Maybe +import System.Random.MWC +import qualified Honeycomb.Config as Config +import Honeycomb.Types +import Honeycomb.Client.Internal +import qualified Honeycomb.API.Events as API +import qualified Honeycomb.API.Types as API +import Network.HTTP.Client.TLS +import UnliftIO.Async hiding (atomically) +import UnliftIO +import Control.Monad.Reader +import Control.Concurrent.STM (retry) +import Control.Concurrent.STM.TBQueue hiding (newTBQueueIO) +import Control.Concurrent +import Lens.Micro ((%~), (^.), (&)) +import Lens.Micro.Extras (view) + +initializeHoneycomb :: MonadIO m => Config.Config -> m HoneycombClient +initializeHoneycomb conf = liftIO $ do + putStrLn "Initialize honeycomb client" + rand <- liftIO createSystemRandom + buf <- liftIO $ newTBQueueIO (fromIntegral $ Config.pendingQueueSize conf) + sendThreadCount <- fmap (max 1) $ if Config.sendThreads conf == 0 + then liftIO (fmap fromIntegral getNumCapabilities) + else pure $ fromIntegral $ Config.sendThreads conf + liftIO $ print ("sendThreadCount"::String, sendThreadCount) + -- TODO this will lose some events upon cancellation, so we need to handle that by properly + -- flushing everything. + innerWorkers <- liftIO $ replicateM (fromIntegral $ Config.sendThreads conf) $ async $ do + putStrLn "Booting worker thread" + forever $ do + actions <- mask_ $ liftIO $ do + items <- atomically $ flushTBQueue buf + -- TODO do something better than exception printing + handle (\e -> print (e :: SomeException) *> throwIO e) $ sequence_ items + pure items + -- A little hack to retry outside of mask so that way we can cancel in between outbound calls + case actions of + [] -> atomically $ void $ peekTBQueue buf + _ -> pure () + pure $ HoneycombClient conf rand buf innerWorkers + +shutdownHoneycomb :: MonadIO m => HoneycombClient -> m () +shutdownHoneycomb = mapM_ cancel . clientWorkers + +event :: Event +event = Event + { fields = S.empty + , teamWriteKey = Nothing + , dataset = Nothing + , apiHost = Nothing + , sampleRate = Nothing + , timestamp = Nothing + } + +class ToEventField a where +class ToEventFields a where + +send :: (MonadIO m, HasHoneycombClient env) => env -> Event -> m () +send hasC e = do + let c@HoneycombClient{..} = hasC ^. honeycombClientL + specifiedSampleRate = sampleRate e <|> Config.sampleRate clientConfig + (shouldSend, _sampleVal) <- case specifiedSampleRate of + Nothing -> pure (True, 0) + Just 1 -> pure (True, 0) + Just n -> liftIO $ do + x <- uniformR (1, n) clientGen + pure (1 == x, x) + when shouldSend $ do + let event_ = API.Event specifiedSampleRate (timestamp e) (fields e) + localOptions = honeycombClientL %~ (\c -> c { clientConfig = replaceDataset $ replaceHost $ replaceWriteKey clientConfig }) + blockingEvent = runReaderT (API.sendEvent event_) (c & localOptions) + liftIO $ if Config.sendBlocking clientConfig + then blockingEvent + else atomically $ writeTBQueue clientEventBuffer blockingEvent + where + replaceDataset :: Config.Config -> Config.Config + replaceDataset c' = maybe c' (\ds -> c' { Config.defaultDataset = ds }) $ dataset e + replaceHost :: Config.Config -> Config.Config + replaceHost c' = maybe c' (\h -> c' { Config.apiHost = h }) $ apiHost e + replaceWriteKey :: Config.Config -> Config.Config + replaceWriteKey c' = maybe c' (\k -> c' { Config.teamWritekey = k }) $ teamWriteKey e diff --git a/src/Honeycomb/API/Boards.hs b/src/Honeycomb/API/Boards.hs new file mode 100644 --- /dev/null +++ b/src/Honeycomb/API/Boards.hs @@ -0,0 +1,10 @@ +module Honeycomb.API.Boards where + +{- + +createBoard +retrieveBoard +updateBoard +deleteBoard +listAllBoards +-} diff --git a/src/Honeycomb/API/Columns.hs b/src/Honeycomb/API/Columns.hs new file mode 100644 --- /dev/null +++ b/src/Honeycomb/API/Columns.hs @@ -0,0 +1,33 @@ +module Honeycomb.API.Columns where + +import Data.Text (Text) +-- import Honeycomb.Types + +data ColumnType + = StringType + | FloatType + | IntegerType + | BooleanType + +newtype ColumnId = ColumnId Text + +data ExistingColumn = ExistingColumn + { columnId :: ColumnId + , columnData :: Column + } + +data Column = Column + { keyName :: Text + , hidden :: Bool + , description :: Maybe Text + , columnType :: Maybe ColumnType + } + +{- +createColumn :: DatasetName -> Column -> ExistingColumn +updateColumn :: DatasetName -> Column -> ExistingColumn +deleteColumn :: DatasetName -> ColumnId -> ExistingColumn +getColumn :: DatasetName -> ColumnId -> Maybe ExistingColumn +getColumnByKeyName :: DatasetName -> Text -> Maybe ExistingColumn +listAllColumns :: DatasetName -> [ExistingColumn] +-} diff --git a/src/Honeycomb/API/Datasets.hs b/src/Honeycomb/API/Datasets.hs new file mode 100644 --- /dev/null +++ b/src/Honeycomb/API/Datasets.hs @@ -0,0 +1,26 @@ +module Honeycomb.API.Datasets where + +import Data.Text (Text) +-- import Data.Vector (Vector) +-- import Honeycomb.Client +import Honeycomb.Types + +newtype NewDataset = NewDataset + { newDatasetName :: Text + } + +data Dataset = Dataset + { datasetName :: Text + , datasetSlug :: DatasetName + } + +{- +createDataset :: Client -> NewDataset -> m Dataset +createDataset = post c [] ["1", "datasets"] + +getDataset :: Client -> DatasetName -> m (Maybe Dataset) +getDataset c (DatasetName d) = get c [] ["1", "datasets", d] + +getAllDatasets :: Client -> m (Vector Dataset) +getAllDatasets c = get c [] ["1", "datasets"] +-} diff --git a/src/Honeycomb/API/DerivedColumns.hs b/src/Honeycomb/API/DerivedColumns.hs new file mode 100644 --- /dev/null +++ b/src/Honeycomb/API/DerivedColumns.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE GADTs #-} +module Honeycomb.API.DerivedColumns where + + +import Data.Text (Text) +import Honeycomb.Types (DatasetName) +import Honeycomb.Client.Internal + +newtype Expression = Expression Text + +data DerivedColumn = DerivedColumn + { alias :: Text + , description :: Maybe Text + , expression :: Expression + } + +newtype DerivedColumnId = DerivedColumnId Text + +data ExistingDerivedColumn = ExistingDerivedColumn + { derivedColumnId :: DerivedColumnId + , derivedColumnDetails :: DerivedColumn + } + +{- +createDerivedColumn :: DatasetName -> DerivedColumn -> m ExistingDerivedColumn +createDerivedColumn = post $ error "TODO" + +updateDerivedColumn :: DatasetName -> ExistingDerivedColumn -> m ExistingDerivedColumn +updateDerivedColumn = put $ error "TODO" + +deleteDerivedColumn :: DatasetName -> DerivedColumnId -> m Bool +deleteDerivedColumn = delete $ error "TODO" + +getOneDerivedColumn :: DatasetName -> DerivedColumnId -> m (Maybe ExistingDerivedColumn) +getOneDerivedColumn = get $ error "TODO" + +getOneDerivedColumnByAlias :: DatasetName -> Text -> m (Maybe ExistingDerivedColumn) +getOneDerivedColumnByAlias = get $ error "TODO" + +listAllDerivedColumns :: DatasetName -> m [ExistingDerivedColumn] +listAllDerivedColumns = get $ error "TODO" +-} + +{- +data Expression a where + ColumnName :: Text -> Expression () + Function :: Expression () + StringLit :: Text -> Expression Text + NumLit :: Scientific -> Expression Scientific + BoolLit :: Bool -> Expression Bool + NullLit :: Expression a + + +ifE :: Expression Bool -> Expression a -> Expression a +ifElseE :: Expression Bool -> Expression a -> Expression a -> Expression a +multiWayIfE :: Expression Bool -> NonEmpty (Expression a, Expression a) -> Expression a + +coalesce :: [Expression a] -> Expression a + +lt :: Expression a -> Expression b -> Expression Bool +lte :: Expression a -> Expression b -> Expression Bool +gt :: Expression a -> Expression b -> Expression Bool +gte :: Expression a -> Expression b -> Expression Bool +equals :: Expression a -> Expression b -> Expression Bool +in_ :: Expression a -> [Expression b] -> Expression Bool +exists :: Expression a -> Expression Bool +not :: Expression Bool -> Expression Bool +and :: Expression Bool -> Expression Bool -> Expression Bool +or :: Expression +min +max +sum +sub +mul +log10 +bucket + +-- $ Cast operators +int +float +bool +string +concat +startsWith +contains +regMatch +regValue +regCount +unixTimestamp +eventTimestamp +ingestTimestamp +-} diff --git a/src/Honeycomb/API/Events.hs b/src/Honeycomb/API/Events.hs new file mode 100644 --- /dev/null +++ b/src/Honeycomb/API/Events.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Honeycomb.API.Events + ( Event(..) + , sendEvent + , sendBatchedEvents + , sendBatchedEvents' + , BatchResponse(..) + , BatchOptions(..) + ) where +import Chronos ( timeToDatetime ) +import Control.Exception +import Data.Aeson +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy as L +import Control.Monad.IO.Class +import Data.Maybe +import qualified Data.Text.Encoding as T +import Data.Typeable +import Data.Vector (Vector) +import Honeycomb.Client.Internal hiding (Event) +import Honeycomb.Types +import Honeycomb.API.Types +import Network.HTTP.Simple +import Network.HTTP.Types +import Lens.Micro ( (^.), to, ) +import Control.Monad.Reader (MonadReader, asks) +import Lens.Micro.Extras (view) +import Honeycomb.Config (defaultDataset, configL) + +data MalformedJSONResponse = MalformedJSONResponse + { malformedJSONResponseMessage :: String + , malformedJSONResponseBody :: L.ByteString + } + deriving stock (Show, Typeable) + deriving anyclass (Exception) + +data FailureResponse + = UnknownApiKey + | RequestBodyTooLarge + | MalformedRequestBody + | EventDroppedDueToThrottling + | EventDroppedDueToBlacklist + | RequestDroppedDueToRateLimiting + | UnrecognizedError Status L.ByteString + deriving stock (Show, Typeable) + deriving anyclass (Exception) + +sendEvent :: (MonadHoneycomb client m) => Event -> m () +sendEvent e = do + client <- asks (view honeycombClientL) + let ds = client ^. configL . to defaultDataset + r <- post httpLBS ["1", "events", "ds"] hs $ eventData e + case (statusCode $ getResponseStatus r, getResponseBody r) of + (400, "unknown API key - check your credentials") -> throw UnknownApiKey + (400, "request body is too large") -> throw RequestBodyTooLarge + (400, "request body is malformed and cannot be read as JSON") -> throw MalformedRequestBody + (403, "event dropped due to administrative throttling") -> throw EventDroppedDueToThrottling + (429, "event dropped due to administrative blacklist") -> throw EventDroppedDueToBlacklist + (429, "request dropped due to rate limiting") -> throw RequestDroppedDueToRateLimiting + (200, _) -> pure () + (_, str) -> throw $ UnrecognizedError (getResponseStatus r) str + where + hs = catMaybes + [ (\d -> ("X-Honeycomb-Event-Time", T.encodeUtf8 $ encodeRFC3339 $ timeToDatetime d)) <$> eventTimestamp e + , (\r -> ("X-Honeycomb-Samplerate", C.pack $ show r)) <$> eventSampleRate e + ] + +{- +There are a few limits to note in regards to the events API: + +Requests to the individual event endpoint have a maximum request body size of 100KB. +Requests to the batched events endpoint have a maximum request body size of 5MB. Individual event bodies in the batch are limited to 100KB each. +The maximum number of distinct columns (fields) allowed per event is 2000. + +Size limitations may be addressed by gzipping request bodies. Be sure to set the Content-Encoding: gzip +-} +newtype BatchOptions = BatchOptions + { useGZip :: Bool + } deriving (Show, Read) + +sendBatchedEvents :: (MonadHoneycomb client m) => Vector Event -> m (Vector BatchResponse) +sendBatchedEvents = sendBatchedEvents' (BatchOptions False) + +newtype BatchResponse = BatchResponse { batchResponseStatus :: Int } + deriving (Show) + +instance FromJSON BatchResponse where + parseJSON = withObject "BatchResponse" $ \o -> BatchResponse <$> (o .: "status") + +sendBatchedEvents' :: (MonadHoneycomb client m) => BatchOptions -> Vector Event -> m (Vector BatchResponse) +sendBatchedEvents' _ events = do + config <- asks (view (honeycombClientL . configL)) + let ds = defaultDataset config + r <- post httpLBS ["1", "batch", "ds"] [] events + case getResponseBody $ decodeJSON r of + Left err -> throw $ MalformedJSONResponse err (getResponseBody r) + Right ok -> pure ok diff --git a/src/Honeycomb/API/Markers.hs b/src/Honeycomb/API/Markers.hs new file mode 100644 --- /dev/null +++ b/src/Honeycomb/API/Markers.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE NumericUnderscores #-} +module Honeycomb.API.Markers + ( Marker(..) + , emptyMarker + , ExistingMarker(..) + , createMarker + ) where + +import Chronos +import Data.Text (Text) +-- import Honeycomb.Client +import Network.HTTP.Simple +import Data.Aeson +import Honeycomb.Client.Internal +import Honeycomb.Types +import Data.Int +import Lens.Micro.Extras (view) +import Control.Monad.Reader (asks) +import Honeycomb.Config (defaultDataset) + +data Marker = Marker + { startTime :: Maybe Time + , endTime :: Maybe Time + , message :: Maybe Text + , markerType :: Maybe Text + , url :: Maybe Text + } deriving (Show, Eq) + +emptyMarker :: Marker +emptyMarker = Marker + { startTime = Nothing + , endTime = Nothing + , message = Nothing + , markerType = Nothing + , url = Nothing + } + +getSeconds :: Time -> Int64 +getSeconds = (`div` 1_000_000_000) . getTime + +fromSeconds :: Int64 -> Time +fromSeconds = Time . (* 1_000_000_000) + +instance ToJSON Marker where + toJSON Marker{..} = object + [ "start_time" .= (getSeconds <$> startTime) + , "end_time" .= (getSeconds <$> endTime) + , "message" .= message + , "type" .= markerType + , "url" .= url + ] + +instance FromJSON Marker where + parseJSON = withObject "Marker" $ \o -> + Marker <$> + (fmap fromSeconds <$> (o .:? "start_time")) <*> + (fmap fromSeconds <$> (o .:? "end_time")) <*> + o .:? "message" <*> + o .:? "type" <*> + o .:? "url" + +newtype MarkerId = MarkerId { fromMarkerId :: Text } + deriving (Show, Eq, Ord, ToJSON, FromJSON) + +data ExistingMarker = ExistingMarker + { id :: MarkerId + , createdAt :: Text -- TODO current chronos version used in dev doesn't have Datetime FromJSON instance + , updatedAt :: Text -- TODO current chronos version used in dev doesn't have Datetime FromJSON instance + , color :: Maybe Text + , marker :: Marker + } deriving (Show, Eq) + +instance FromJSON ExistingMarker where + parseJSON x = existing x + where + existing = withObject "ExistingMarker" $ \o -> + ExistingMarker <$> o .: "id" <*> o .: "created_at" <*> o .: "updated_at" <*> o .:? "color" <*> parseJSON x + +-- TODO improve error handling +createMarker :: MonadHoneycomb env m => Marker -> m ExistingMarker +createMarker m = do + c <- asks (view honeycombClientL) + let ds = fromDatasetName $ defaultDataset $ clientConfig c + getResponseBody <$> post httpJSON ["1", "markers", "ds"] [] m +-- updateMarker :: Client -> Marker +-- deleteMarker :: Client -> Marker +-- listAllMarkers :: Client -> Marker diff --git a/src/Honeycomb/API/Queries.hs b/src/Honeycomb/API/Queries.hs new file mode 100644 --- /dev/null +++ b/src/Honeycomb/API/Queries.hs @@ -0,0 +1,6 @@ +module Honeycomb.API.Queries where + +{- +createQuery +getQuery +-} diff --git a/src/Honeycomb/API/QueryAnnotations.hs b/src/Honeycomb/API/QueryAnnotations.hs new file mode 100644 --- /dev/null +++ b/src/Honeycomb/API/QueryAnnotations.hs @@ -0,0 +1,9 @@ +module Honeycomb.API.QueryAnnotations where + +{- +createQueryAnnotation +getQueryAnnotation +updateQueryAnnotation +deleteQueryAnnotation +listAllQueryAnnotation +-} diff --git a/src/Honeycomb/API/Triggers.hs b/src/Honeycomb/API/Triggers.hs new file mode 100644 --- /dev/null +++ b/src/Honeycomb/API/Triggers.hs @@ -0,0 +1,9 @@ +module Honeycomb.API.Triggers where + +{- +createTrigger +retrieveTrigger +updateTrigger +deleteTrigger +listAllTriggers +-} diff --git a/src/Honeycomb/API/Types.hs b/src/Honeycomb/API/Types.hs new file mode 100644 --- /dev/null +++ b/src/Honeycomb/API/Types.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Honeycomb.API.Types where + +import Chronos + ( builder_YmdHMS, + timeToDatetime, + w3c, + Datetime, + SubsecondPrecision(SubsecondPrecisionFixed), + Time ) +import Data.Aeson +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Builder as TB +import Data.Word + +data Event = Event + { eventSampleRate :: !(Maybe Word64) + , eventTimestamp :: !(Maybe Time) + , eventData :: !Object + } + +instance ToJSON Event where + toJSON Event{..} = object $ ("data" .= eventData) : catMaybes + [ (\x -> "time" .= encodeRFC3339 (timeToDatetime x)) <$> eventTimestamp + , ("samplerate" .=) <$> eventSampleRate + ] + toEncoding Event{..} = pairs $ mconcat + [ "data" .= eventData + , maybe mempty (\x -> "time" .= encodeRFC3339 (timeToDatetime x)) eventTimestamp + , maybe mempty ("samplerate" .=) eventSampleRate + ] + +-- | Construct a 'Text' 'TB.Builder' corresponding to the ISO-8601 +-- encoding of the given 'Datetime'. +builderRFC3339 :: Datetime -> TB.Builder +builderRFC3339 dt = builder_YmdHMS (SubsecondPrecisionFixed 8) w3c dt <> "Z" + +-- | Construct 'Text' corresponding to the ISO-8601 +-- encoding of the given 'Datetime'. +encodeRFC3339 :: Datetime -> Text +encodeRFC3339 = LT.toStrict . TB.toLazyText . builderRFC3339 diff --git a/src/Honeycomb/Client/Internal.hs b/src/Honeycomb/Client/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Honeycomb/Client/Internal.hs @@ -0,0 +1,92 @@ +{-# 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 + { clientConfig :: Config + , 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. + , clientEventBuffer :: TBQueue (IO ()) + -- , clientQueueMap :: Map ThreadId + , clientWorkers :: [Async ()] + } + +class 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 }) + +type MonadHoneycomb env m = (MonadIO m, HasHoneycombClient env, MonadReader env m) + +data Event = Event + { fields :: S.HashMap Text Value + , teamWriteKey :: Maybe Text + , dataset :: Maybe DatasetName + , apiHost :: Maybe Text + , sampleRate :: Maybe Word64 + , timestamp :: Maybe Time + } + + +post :: (MonadIO m, MonadHoneycomb 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 + } + f req + +get :: (MonadIO m, MonadHoneycomb env m, FromJSON a) => (Request -> m (Response b)) -> [Text] -> [(Text, Text)] -> m a +get = undefined + +put :: (MonadIO m, MonadHoneycomb env m, FromJSON a) => (Request -> m (Response b)) -> [Text] -> [(Text, Text)] -> m a +put = undefined + +delete :: (MonadIO m, MonadHoneycomb env m, FromJSON a) => (Request -> m (Response b)) -> [Text] -> [(Text, Text)] -> m a +delete = undefined + +decodeJSON :: FromJSON a => Response L.ByteString -> Response (Either String a) +decodeJSON = fmap eitherDecode diff --git a/src/Honeycomb/Config.hs b/src/Honeycomb/Config.hs new file mode 100644 --- /dev/null +++ b/src/Honeycomb/Config.hs @@ -0,0 +1,36 @@ +module Honeycomb.Config where +import Honeycomb.Types +import Data.Text (Text) +import Lens.Micro (Lens', lens) +import Data.ByteString (ByteString) +import Data.Word (Word64) + +data Config = Config + { teamWritekey :: Text + , defaultDataset :: DatasetName + , apiHost :: Text + , sampleRate :: Maybe Word64 + , pendingQueueSize :: Word64 + -- , responseQueueSize :: Word64 + , sendThreads :: Word64 + , sendBlocking :: Bool + , nullTransmission :: Bool -- TODO + , customUserAgent :: ByteString -- TODO + } + +class HasConfig a where + configL :: Lens' a Config + +instance HasConfig Config where + configL = lens id (\_ new -> new) + +-- | Smart constructor with sane defaults for Honeycomb config options. +-- +-- To alter options, import @Honeycomb.Config@ +-- +-- > import qualified Honeycomb.Config as Config +-- > config { Config.pendingQueueSize = 512 } +-- +-- @since 0.0.1 +config :: Text -> DatasetName -> Config +config k ds = Config k ds "api.honeycomb.io" Nothing 1024 1 False False "" diff --git a/src/Honeycomb/Types.hs b/src/Honeycomb/Types.hs new file mode 100644 --- /dev/null +++ b/src/Honeycomb/Types.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Honeycomb.Types + ( DatasetName(..) + ) where +import Lens.Micro (Lens', lens) +import Data.ByteString.Char8 (ByteString) +import Data.Text (Text) +import Data.Word +import Data.String (IsString) + +newtype DatasetName = DatasetName { fromDatasetName :: Text } + deriving (Show, Eq, Ord, IsString) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"