packages feed

honeycomb (empty) → 0.0.0.1

raw patch · 20 files changed

+835/−0 lines, 20 filesdep +aesondep +asyncdep +auto-updatesetup-changed

Dependencies added: aeson, async, auto-update, base, bytestring, chronos, honeycomb, http-client, http-client-tls, http-conduit, http-types, microlens, mmorph, monad-control, mtl, mwc-random, profunctors, random, resource-pool, stm, text, unliftio, unordered-containers, uuid, vector, zlib

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for honeycomb++## Unreleased changes
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ honeycomb.cabal view
@@ -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 <https://github.com/githubuser/honeycomb#readme>+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
+ src/Honeycomb.hs view
@@ -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
+ src/Honeycomb/API/Boards.hs view
@@ -0,0 +1,10 @@+module Honeycomb.API.Boards where++{-++createBoard+retrieveBoard+updateBoard+deleteBoard+listAllBoards+-}
+ src/Honeycomb/API/Columns.hs view
@@ -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]+-}
+ src/Honeycomb/API/Datasets.hs view
@@ -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"]+-}
+ src/Honeycomb/API/DerivedColumns.hs view
@@ -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+-}
+ src/Honeycomb/API/Events.hs view
@@ -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
+ src/Honeycomb/API/Markers.hs view
@@ -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
+ src/Honeycomb/API/Queries.hs view
@@ -0,0 +1,6 @@+module Honeycomb.API.Queries where++{-+createQuery+getQuery+-}
+ src/Honeycomb/API/QueryAnnotations.hs view
@@ -0,0 +1,9 @@+module Honeycomb.API.QueryAnnotations where++{-+createQueryAnnotation+getQueryAnnotation+updateQueryAnnotation+deleteQueryAnnotation+listAllQueryAnnotation+-}
+ src/Honeycomb/API/Triggers.hs view
@@ -0,0 +1,9 @@+module Honeycomb.API.Triggers where++{-+createTrigger+retrieveTrigger+updateTrigger+deleteTrigger+listAllTriggers+-}
+ src/Honeycomb/API/Types.hs view
@@ -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
+ src/Honeycomb/Client/Internal.hs view
@@ -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
+ src/Honeycomb/Config.hs view
@@ -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 ""
+ src/Honeycomb/Types.hs view
@@ -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)
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"