{-# LANGUAGE ExistentialQuantification, RankNTypes, UndecidableInstances #-}
module Tracing.Core (
Span(..),
SpanRelation(..),
SpanRelationTag(..),
SpanContext(..),
SpanTag(..),
OpName(..),
SpanId(..),
TraceId(..),
Tracer(..),
TracingInstructions(..),
MonadTracer(..),
ToSpanTag(..),
Tag(..),
recordSpan,
debugPrintSpan
) where
import Control.Arrow ((&&&))
import Control.Exception.Lifted (bracket)
import Control.Monad.Trans (liftIO, MonadIO)
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.ByteString.Lazy as BSL
import Data.Time.Clock (NominalDiffTime, UTCTime, getCurrentTime, diffUTCTime)
import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds)
import Data.Int
import Data.Aeson (ToJSON, encode)
import Data.Maybe (isJust)
import Data.Monoid ((<>))
import Data.String (IsString)
import System.Random (randomRIO)
import Data.IORef (IORef, atomicModifyIORef',readIORef)
import qualified Data.Map.Strict as M
import Web.HttpApiData (FromHttpApiData)
newtype OpName = OpName Text
deriving (Eq, Ord, Show, IsString)
newtype SpanId = SpanId Int64
deriving (Eq, Ord, Show, FromHttpApiData)
newtype TraceId = TraceId Int64
deriving (Eq, Ord, Show, FromHttpApiData)
class Monad m => MonadTracer m where
getTracer :: m Tracer
currentTrace :: m TraceId
currentSpan :: m (IORef SpanId)
isDebug :: m Bool
recordSpan :: (MonadIO m, MonadBaseControl IO m, MonadTracer m) =>
Maybe SpanRelationTag
-> [Tag]
-> OpName
-> m a
-> m a
recordSpan spanType tags opName action = do
Tracer {svcName=serviceName, spanBuffer} <- getTracer
currentSpanCell <- currentSpan
activeSpanId <- liftIO $ readIORef currentSpanCell
traceId <- currentTrace
debug <- isDebug
let startSpan = do
now <- liftIO getCurrentTime
newSpanId <- fmap SpanId . liftIO $ randomRIO (0, maxBound)
let loggedSpanId = resolveSpanId activeSpanId newSpanId
rel = newSpanRelation traceId activeSpanId
makeSpan ts =
Span {
operationName = opName,
context = SpanContext traceId loggedSpanId,
timestamp = utcTimeToPOSIXSeconds now,
relations = rel,
tags = M.fromList $ (\(Tag key t) -> (key, toSpanTag t) ) <$> tags,
baggage = M.empty,
duration = diffUTCTime ts now,
debug,
serviceName
}
liftIO $ atomicModifyIORef' currentSpanCell (const (newSpanId, ()))
pure $ ActiveSpan makeSpan
closeSpan (ActiveSpan finishSpan) = do
now <- liftIO getCurrentTime
let span = finishSpan now
sid = spanId (context span :: SpanContext)
liftIO $ atomicModifyIORef' spanBuffer (\xs -> (span:xs, ()))
liftIO $ atomicModifyIORef' currentSpanCell (const (activeSpanId, ()))
bracket startSpan
closeSpan
(const action)
where
resolveSpanId activeSpanId newSpanId =
if isJust spanType
then newSpanId
else activeSpanId
newSpanRelation traceId activeSpanId =
case spanType of
Just Child -> [ChildOf $ SpanContext traceId activeSpanId]
Just Follows -> [FollowsFrom $ SpanContext traceId activeSpanId]
Nothing -> []
data TracingInstructions =
TracingInstructions {
traceId :: !TraceId,
spanId :: !SpanId,
parentSpanId :: !SpanId,
debug :: !Bool,
sample :: !Bool
} deriving (Eq, Show)
newtype ActiveSpan =
ActiveSpan {finishSpan :: UTCTime -> Span}
data Tracer =
Tracer {
spanBuffer :: IORef [Span],
svcName :: T.Text
}
data SpanContext =
SpanContext {
traceId :: !TraceId,
spanId :: !SpanId
} deriving (Eq, Show)
data SpanRelation =
ChildOf !SpanContext | FollowsFrom !SpanContext
deriving (Eq, Show)
data SpanRelationTag = Child | Follows
data Span = Span {
operationName :: !OpName,
context :: !SpanContext,
timestamp :: !POSIXTime,
duration :: !NominalDiffTime,
relations :: ![SpanRelation],
tags :: !(M.Map Text SpanTag),
baggage:: !(M.Map Text Text),
debug :: !Bool,
serviceName :: !Text
} deriving Show
debugPrintSpan ::
Span
-> Text
debugPrintSpan span =
"Span: " <>
"id ["<>(unSpan $ spanId (context span :: SpanContext))<>"] "<>
"op ["<>(unOp $ operationName span)<>"] "<>
"duration ["<>(T.pack . show $ duration span)<> "] "<>
"relations "<>(T.pack . show $ relations span)
where
unOp (OpName o) = o
unSpan (SpanId s) = T.pack $ show s
data SpanTag
= TagString !Text
| TagBool !Bool
| TagInt !Int64
| TagDouble !Double
deriving (Eq, Show)
data Tag = forall a. ToSpanTag a => Tag T.Text a
class ToSpanTag a where
toSpanTag :: a -> SpanTag
instance ToSpanTag SpanTag where
toSpanTag = id
instance ToJSON a => ToSpanTag a where
toSpanTag = TagString . T.decodeUtf8 . BSL.toStrict . encode