{-# 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 :: Config -> m HoneycombClient
initializeHoneycomb Config
conf = IO HoneycombClient -> m HoneycombClient
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HoneycombClient -> m HoneycombClient)
-> IO HoneycombClient -> m HoneycombClient
forall a b. (a -> b) -> a -> b
$ do
  String -> IO ()
putStrLn String
"Initialize honeycomb client"
  Gen RealWorld
rand <- IO (Gen RealWorld) -> IO (Gen RealWorld)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Gen RealWorld)
IO GenIO
createSystemRandom
  TBQueue (IO ())
buf <- IO (TBQueue (IO ())) -> IO (TBQueue (IO ()))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TBQueue (IO ())) -> IO (TBQueue (IO ())))
-> IO (TBQueue (IO ())) -> IO (TBQueue (IO ()))
forall a b. (a -> b) -> a -> b
$ Natural -> IO (TBQueue (IO ()))
forall (m :: * -> *) a. MonadIO m => Natural -> m (TBQueue a)
newTBQueueIO (Word64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Natural) -> Word64 -> Natural
forall a b. (a -> b) -> a -> b
$ Config -> Word64
Config.pendingQueueSize Config
conf)
  Integer
sendThreadCount <- (Integer -> Integer) -> IO Integer -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
1) (IO Integer -> IO Integer) -> IO Integer -> IO Integer
forall a b. (a -> b) -> a -> b
$ if Config -> Word64
Config.sendThreads Config
conf Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0
    then IO Integer -> IO Integer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((Int -> Integer) -> IO Int -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral IO Int
getNumCapabilities)
    else Integer -> IO Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> IO Integer) -> Integer -> IO Integer
forall a b. (a -> b) -> a -> b
$ Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ Config -> Word64
Config.sendThreads Config
conf
  IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (String, Integer) -> IO ()
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 <- IO [Async ()] -> IO [Async ()]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Async ()] -> IO [Async ()]) -> IO [Async ()] -> IO [Async ()]
forall a b. (a -> b) -> a -> b
$ Int -> IO (Async ()) -> IO [Async ()]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ Config -> Word64
Config.sendThreads Config
conf) (IO (Async ()) -> IO [Async ()]) -> IO (Async ()) -> IO [Async ()]
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
putStrLn String
"Booting worker thread"
    IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [IO ()]
actions <- IO [IO ()] -> IO [IO ()]
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m a
mask_ (IO [IO ()] -> IO [IO ()]) -> IO [IO ()] -> IO [IO ()]
forall a b. (a -> b) -> a -> b
$ IO [IO ()] -> IO [IO ()]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [IO ()] -> IO [IO ()]) -> IO [IO ()] -> IO [IO ()]
forall a b. (a -> b) -> a -> b
$ do
        [IO ()]
items <- STM [IO ()] -> IO [IO ()]
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM [IO ()] -> IO [IO ()]) -> STM [IO ()] -> IO [IO ()]
forall a b. (a -> b) -> a -> b
$ TBQueue (IO ()) -> STM [IO ()]
forall a. TBQueue a -> STM [a]
flushTBQueue TBQueue (IO ())
buf
        -- TODO do something better than exception printing
        (SomeException -> IO ()) -> IO () -> IO ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> m a) -> m a -> m a
handle (\SomeException
e -> SomeException -> IO ()
forall a. Show a => a -> IO ()
print (SomeException
e :: SomeException) IO () -> IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> SomeException -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
e) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IO ()]
items
        [IO ()] -> IO [IO ()]
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
        [] -> STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM (IO ()) -> STM ()) -> STM (IO ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ TBQueue (IO ()) -> STM (IO ())
forall a. TBQueue a -> STM a
peekTBQueue TBQueue (IO ())
buf
        [IO ()]
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  HoneycombClient -> IO HoneycombClient
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HoneycombClient -> IO HoneycombClient)
-> HoneycombClient -> IO HoneycombClient
forall a b. (a -> b) -> a -> b
$ Config -> GenIO -> TBQueue (IO ()) -> [Async ()] -> HoneycombClient
HoneycombClient Config
conf Gen RealWorld
GenIO
rand TBQueue (IO ())
buf [Async ()]
innerWorkers

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

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

class ToEventField a where
class ToEventFields a where

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