{-# 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)
import qualified Data.Aeson.KeyMap as KeyMap

initializeHoneycomb :: MonadIO m => Config.Config -> m HoneycombClient
initializeHoneycomb :: forall (m :: * -> *). MonadIO m => Config -> m HoneycombClient
initializeHoneycomb Config
conf = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  String -> IO ()
putStrLn String
"Initialize honeycomb client"
  Gen RealWorld
rand <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO GenIO
createSystemRandom
  TBQueue (IO ())
buf <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => Natural -> m (TBQueue a)
newTBQueueIO (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Config -> Word64
Config.pendingQueueSize Config
conf)
  Integer
sendThreadCount <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Ord a => a -> a -> a
max Integer
1) forall a b. (a -> b) -> a -> b
$ if Config -> Word64
Config.sendThreads Config
conf forall a. Eq a => a -> a -> Bool
== Word64
0
    then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral IO Int
getNumCapabilities)
    else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Config -> Word64
Config.sendThreads Config
conf
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> IO ()
print (String
"sendThreadCount"::String, Integer
sendThreadCount)
  -- TODO this will lose some events upon cancellation, so we need to handle that by properly
  -- flushing everything.
  [Async ()]
innerWorkers <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Config -> Word64
Config.sendThreads Config
conf) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
putStrLn String
"Booting worker thread"
    forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
      [IO ()]
actions <- forall (m :: * -> *) a. MonadUnliftIO m => m a -> m a
mask_ forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        [IO ()]
items <- forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TBQueue a -> STM [a]
flushTBQueue TBQueue (IO ())
buf
        -- TODO do something better than exception printing
        forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> m a) -> m a -> m a
handle (\SomeException
e -> forall a. Show a => a -> IO ()
print (SomeException
e :: SomeException) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
e) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IO ()]
items
        forall (f :: * -> *) a. Applicative f => a -> f a
pure [IO ()]
items
      -- A little hack to retry outside of mask so that way we can cancel in between outbound calls
      case [IO ()]
actions of
        [] -> forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. TBQueue a -> STM a
peekTBQueue TBQueue (IO ())
buf
        [IO ()]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Config -> GenIO -> TBQueue (IO ()) -> [Async ()] -> HoneycombClient
HoneycombClient Config
conf Gen RealWorld
rand TBQueue (IO ())
buf [Async ()]
innerWorkers

shutdownHoneycomb :: MonadIO m => HoneycombClient -> m ()
shutdownHoneycomb :: forall (m :: * -> *). MonadIO m => HoneycombClient -> m ()
shutdownHoneycomb = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *) a. MonadIO m => Async a -> m ()
cancel forall b c a. (b -> c) -> (a -> b) -> a -> c
. HoneycombClient -> [Async ()]
clientWorkers

event :: Event
event :: Event
event = Event
  { fields :: HashMap Text Value
fields = forall k v. HashMap k v
S.empty
  , teamWriteKey :: Maybe Text
teamWriteKey = forall a. Maybe a
Nothing
  , dataset :: Maybe DatasetName
dataset = forall a. Maybe a
Nothing
  , apiHost :: Maybe Text
apiHost = forall a. Maybe a
Nothing
  , sampleRate :: Maybe Word64
sampleRate = forall a. Maybe a
Nothing
  , timestamp :: Maybe Time
timestamp = forall a. Maybe a
Nothing
  }

class ToEventField a where
class ToEventFields a where

send :: (MonadIO m, HasHoneycombClient env) => env -> Event -> m ()
send :: forall (m :: * -> *) env.
(MonadIO m, HasHoneycombClient env) =>
env -> Event -> m ()
send env
hasC Event
e = do
  let c :: HoneycombClient
c@HoneycombClient{[Async ()]
GenIO
TBQueue (IO ())
Config
clientEventBuffer :: HoneycombClient -> TBQueue (IO ())
clientGen :: HoneycombClient -> GenIO
clientConfig :: HoneycombClient -> Config
clientWorkers :: [Async ()]
clientEventBuffer :: TBQueue (IO ())
clientGen :: GenIO
clientConfig :: Config
clientWorkers :: HoneycombClient -> [Async ()]
..} = env
hasC forall s a. s -> Getting a s a -> a
^. forall a. HasHoneycombClient a => Lens' a HoneycombClient
honeycombClientL
      specifiedSampleRate :: Maybe Word64
specifiedSampleRate = Event -> Maybe Word64
sampleRate Event
e forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Config -> Maybe Word64
Config.sampleRate Config
clientConfig
  (Bool
shouldSend, Word64
_sampleVal) <- case Maybe Word64
specifiedSampleRate of
    Maybe Word64
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
True, Word64
0)
    Just Word64
1 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
True, Word64
0)
    Just Word64
n -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
      Word64
x <- forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
(a, a) -> Gen (PrimState m) -> m a
uniformR (Word64
1, Word64
n) GenIO
clientGen
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64
1 forall a. Eq a => a -> a -> Bool
== Word64
x, Word64
x)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldSend forall a b. (a -> b) -> a -> b
$ do
    let event_ :: Event
event_ = Maybe Word64 -> Maybe Time -> Object -> Event
API.Event Maybe Word64
specifiedSampleRate (Event -> Maybe Time
timestamp Event
e) (forall v. HashMap Text v -> KeyMap v
KeyMap.fromHashMapText forall a b. (a -> b) -> a -> b
$ Event -> HashMap Text Value
fields Event
e)
        localOptions :: HoneycombClient -> HoneycombClient
localOptions = forall a. HasHoneycombClient a => Lens' a HoneycombClient
honeycombClientL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (\HoneycombClient
c -> HoneycombClient
c { clientConfig :: Config
clientConfig = Config -> Config
replaceDataset forall a b. (a -> b) -> a -> b
$ Config -> Config
replaceHost forall a b. (a -> b) -> a -> b
$ Config -> Config
replaceWriteKey Config
clientConfig })
        blockingEvent :: IO ()
blockingEvent = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall client (m :: * -> *).
MonadHoneycomb client m =>
Event -> m ()
API.sendEvent Event
event_) (HoneycombClient
c forall a b. a -> (a -> b) -> b
& HoneycombClient -> HoneycombClient
localOptions)
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ if Config -> Bool
Config.sendBlocking Config
clientConfig
      then IO ()
blockingEvent
      else forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue (IO ())
clientEventBuffer IO ()
blockingEvent
  where
    replaceDataset :: Config.Config -> Config.Config
    replaceDataset :: Config -> Config
replaceDataset Config
c' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Config
c' (\DatasetName
ds -> Config
c' { defaultDataset :: DatasetName
Config.defaultDataset = DatasetName
ds }) forall a b. (a -> b) -> a -> b
$ Event -> Maybe DatasetName
dataset Event
e
    replaceHost :: Config.Config -> Config.Config
    replaceHost :: Config -> Config
replaceHost Config
c' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Config
c' (\Text
h -> Config
c' { apiHost :: Text
Config.apiHost = Text
h }) forall a b. (a -> b) -> a -> b
$ Event -> Maybe Text
apiHost Event
e
    replaceWriteKey :: Config.Config -> Config.Config
    replaceWriteKey :: Config -> Config
replaceWriteKey Config
c' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Config
c' (\Text
k -> Config
c' { teamWritekey :: Text
Config.teamWritekey = Text
k }) forall a b. (a -> b) -> a -> b
$ Event -> Maybe Text
teamWriteKey Event
e