{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}

module Hermod.Tracing.Tracer.Forward
  ( HowToConnect(..)
  , Host
  , Port
  , forwardTracer
  ) where

import           Hermod.Tracing.DocuGenerator
import           Hermod.Tracing.Formatter (FormattedMessage (..), TraceObject)
import           Hermod.Tracing.Types

import           Control.DeepSeq (NFData)
import           Control.Monad.IO.Class
import qualified Control.Tracer as T
import qualified Data.Aeson as AE
import qualified Data.Aeson.Types as AE (Parser)
import           Control.Applicative ((<|>))
import           Data.Kind (Type)
import           Data.Text as T (Text, null, unpack, breakOnEnd, unsnoc)
import           Data.Text.Read as T (decimal)
import           Data.Word (Word16)
import           GHC.Generics (Generic)


-- | Specifies how to connect to the peer.
--
-- Taken from ekg-forward:System.Metrics.Configuration, to avoid dependency.
type Host :: Type
type Host = Text

type Port :: Type
type Port = Word16

type HowToConnect :: Type
data HowToConnect
  = LocalPipe    !FilePath    -- ^ Local pipe (UNIX or Windows).
  | RemoteSocket !Host !Port  -- ^ Remote socket (host and port).
  deriving stock (HowToConnect -> HowToConnect -> Bool
(HowToConnect -> HowToConnect -> Bool)
-> (HowToConnect -> HowToConnect -> Bool) -> Eq HowToConnect
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HowToConnect -> HowToConnect -> Bool
== :: HowToConnect -> HowToConnect -> Bool
$c/= :: HowToConnect -> HowToConnect -> Bool
/= :: HowToConnect -> HowToConnect -> Bool
Eq, (forall x. HowToConnect -> Rep HowToConnect x)
-> (forall x. Rep HowToConnect x -> HowToConnect)
-> Generic HowToConnect
forall x. Rep HowToConnect x -> HowToConnect
forall x. HowToConnect -> Rep HowToConnect x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. HowToConnect -> Rep HowToConnect x
from :: forall x. HowToConnect -> Rep HowToConnect x
$cto :: forall x. Rep HowToConnect x -> HowToConnect
to :: forall x. Rep HowToConnect x -> HowToConnect
Generic)
  deriving anyclass (HowToConnect -> ()
(HowToConnect -> ()) -> NFData HowToConnect
forall a. (a -> ()) -> NFData a
$crnf :: HowToConnect -> ()
rnf :: HowToConnect -> ()
NFData)

instance Show HowToConnect where
  show :: HowToConnect -> FilePath
show = \case
    LocalPipe FilePath
pipe         -> FilePath
pipe
    RemoteSocket Host
host Word16
port -> Host -> FilePath
T.unpack Host
host FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Word16 -> FilePath
forall a. Show a => a -> FilePath
show Word16
port

instance AE.ToJSON HowToConnect where
  toJSON :: HowToConnect -> Value
toJSON     = FilePath -> Value
forall a. ToJSON a => a -> Value
AE.toJSON (FilePath -> Value)
-> (HowToConnect -> FilePath) -> HowToConnect -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HowToConnect -> FilePath
forall a. Show a => a -> FilePath
show
  toEncoding :: HowToConnect -> Encoding
toEncoding = FilePath -> Encoding
forall a. ToJSON a => a -> Encoding
AE.toEncoding (FilePath -> Encoding)
-> (HowToConnect -> FilePath) -> HowToConnect -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HowToConnect -> FilePath
forall a. Show a => a -> FilePath
show

-- first try to host:port, and if that fails revert to parsing any
-- string literal and assume it is a localpipe.
instance AE.FromJSON HowToConnect where
  parseJSON :: Value -> Parser HowToConnect
parseJSON = FilePath
-> (Host -> Parser HowToConnect) -> Value -> Parser HowToConnect
forall a. FilePath -> (Host -> Parser a) -> Value -> Parser a
AE.withText FilePath
"HowToConnect" ((Host -> Parser HowToConnect) -> Value -> Parser HowToConnect)
-> (Host -> Parser HowToConnect) -> Value -> Parser HowToConnect
forall a b. (a -> b) -> a -> b
$ \Host
t ->
        ((Host -> Word16 -> HowToConnect) -> (Host, Word16) -> HowToConnect
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Host -> Word16 -> HowToConnect
RemoteSocket ((Host, Word16) -> HowToConnect)
-> Parser (Host, Word16) -> Parser HowToConnect
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Host -> Parser (Host, Word16)
parseHostPort Host
t)
    Parser HowToConnect -> Parser HowToConnect -> Parser HowToConnect
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (        FilePath -> HowToConnect
LocalPipe    (FilePath -> HowToConnect)
-> Parser FilePath -> Parser HowToConnect
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Host -> Parser FilePath
parseLocalPipe Host
t)

parseLocalPipe :: Text -> AE.Parser FilePath
parseLocalPipe :: Host -> Parser FilePath
parseLocalPipe Host
t
  | Host -> Bool
T.null Host
t = FilePath -> Parser FilePath
forall a. FilePath -> Parser a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"parseLocalPipe: empty Text"
  | Bool
otherwise   = FilePath -> Parser FilePath
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> Parser FilePath) -> FilePath -> Parser FilePath
forall a b. (a -> b) -> a -> b
$ Host -> FilePath
T.unpack Host
t

parseHostPort :: Text -> AE.Parser (Text, Word16)
parseHostPort :: Host -> Parser (Host, Word16)
parseHostPort Host
t
  | Host -> Bool
T.null Host
t
  = FilePath -> Parser (Host, Word16)
forall a. FilePath -> Parser a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"parseHostPort: empty Text"
  | Bool
otherwise
  = let
    (Host
host_, Host
portText) = HasCallStack => Host -> Host -> (Host, Host)
Host -> Host -> (Host, Host)
T.breakOnEnd Host
":" Host
t
    host :: Host
host              = Host -> ((Host, Char) -> Host) -> Maybe (Host, Char) -> Host
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Host
"" (Host, Char) -> Host
forall a b. (a, b) -> a
fst (Host -> Maybe (Host, Char)
T.unsnoc Host
host_)
  in if
    | Host -> Bool
T.null Host
host      -> FilePath -> Parser (Host, Word16)
forall a. FilePath -> Parser a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"parseHostPort: Empty host or no colon found."
    | Host -> Bool
T.null Host
portText  -> FilePath -> Parser (Host, Word16)
forall a. FilePath -> Parser a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"parseHostPort: Empty port."
    | Right (Word16
port, Host
remainder) <- Reader Word16
forall a. Integral a => Reader a
T.decimal Host
portText
    , Host -> Bool
T.null Host
remainder
    , Word16
0 Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word16
port, Word16
port Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word16
65535 -> (Host, Word16) -> Parser (Host, Word16)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Host
host, Word16
port)
    | Bool
otherwise -> FilePath -> Parser (Host, Word16)
forall a. FilePath -> Parser a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"parseHostPort: Non-numeric port or value out of range."


---------------------------------------------------------------------------

-- | It is mandatory to construct only one forwardTracer tracer in any application!
-- Throwing away a forwardTracer tracer and using a new one will result in an exception
forwardTracer :: forall m. (MonadIO m)
  => (TraceObject -> IO ())
  -> Trace m FormattedMessage
forwardTracer :: forall (m :: * -> *).
MonadIO m =>
(TraceObject -> IO ()) -> Trace m FormattedMessage
forwardTracer TraceObject -> IO ()
write =
  Tracer m (LoggingContext, Either TraceControl FormattedMessage)
-> Trace m FormattedMessage
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl FormattedMessage)
 -> Trace m FormattedMessage)
-> Tracer m (LoggingContext, Either TraceControl FormattedMessage)
-> Trace m FormattedMessage
forall a b. (a -> b) -> a -> b
$ TracerA m (LoggingContext, Either TraceControl FormattedMessage) ()
-> Tracer m (LoggingContext, Either TraceControl FormattedMessage)
forall (m :: * -> *) a. TracerA m a () -> Tracer m a
T.arrow (TracerA
   m (LoggingContext, Either TraceControl FormattedMessage) ()
 -> Tracer m (LoggingContext, Either TraceControl FormattedMessage))
-> TracerA
     m (LoggingContext, Either TraceControl FormattedMessage) ()
-> Tracer m (LoggingContext, Either TraceControl FormattedMessage)
forall a b. (a -> b) -> a -> b
$ ((LoggingContext, Either TraceControl FormattedMessage) -> m ())
-> TracerA
     m (LoggingContext, Either TraceControl FormattedMessage) ()
forall (m :: * -> *) a.
Applicative m =>
(a -> m ()) -> TracerA m a ()
T.emit (((LoggingContext, Either TraceControl FormattedMessage) -> m ())
 -> TracerA
      m (LoggingContext, Either TraceControl FormattedMessage) ())
-> ((LoggingContext, Either TraceControl FormattedMessage) -> m ())
-> TracerA
     m (LoggingContext, Either TraceControl FormattedMessage) ()
forall a b. (a -> b) -> a -> b
$ (LoggingContext -> Either TraceControl FormattedMessage -> m ())
-> (LoggingContext, Either TraceControl FormattedMessage) -> m ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry LoggingContext -> Either TraceControl FormattedMessage -> m ()
output
 where
  output ::
       LoggingContext
    -> Either TraceControl FormattedMessage
    -> m ()
  output :: LoggingContext -> Either TraceControl FormattedMessage -> m ()
output LoggingContext{} (Right (FormattedForwarder TraceObject
lo)) =
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ TraceObject -> IO ()
write TraceObject
lo
  output LoggingContext{} (Left TraceControl
TCReset) =
    () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  output LoggingContext
lk (Left c :: TraceControl
c@TCDocument {}) =
    BackendConfig -> (LoggingContext, Either TraceControl Any) -> m ()
forall (m :: * -> *) a.
MonadIO m =>
BackendConfig -> (LoggingContext, Either TraceControl a) -> m ()
docIt BackendConfig
Forwarder (LoggingContext
lk, TraceControl -> Either TraceControl Any
forall a b. a -> Either a b
Left TraceControl
c)
  output LoggingContext{} Either TraceControl FormattedMessage
_ =
    () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()