diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ [![Build Status](https://travis-ci.org/ChrisCoffey/haskell-opentracing-light.svg?branch=master)](https://travis-ci.org/ChrisCoffey/haskell-opentracing-light) -This repository is the minimum required for publishing trace data to Zipkin or Jaeger. It adheres to the [Open Tracing Standard] (https://github.com/opentracing/specification) but is not complete. See the documentation on Hackage for module-level details. +This repository is the minimum required for publishing trace data to Zipkin or Jaeger. It adheres to the [Open Tracing Standard](https://github.com/opentracing/specification) but is missing a few features. See the documentation on Hackage for module-level details. ### Using the library @@ -25,12 +25,13 @@ ### Testing Locally with the Demo App You can start up a compatible server for [Zipkin](https://zipkin.io/pages/quickstart.html) or [Jaeger](https://jaegertracing.netlify.com/docs/deployment/) via a standalone docker container. From there its a matter of seting the following environment variables: -- *TRACING_ENDPOINT*: a `String` with the fully url to a running tracing server +- *TRACING_ENDPOINT*: a `String` with the fully url to a running tracing server. For example, `http://localhost:9411/api/v2/spans` to publish to a Zipkin endpoint. - *TRACING_SERVICE*: a `String` name for your service +Once the a tracing server & the example service are running, you can interact with it via your favorite REST client. The api expects a header named `Auth`, and has two top level endpoints: `fast` & `slow`. Here's an example request: `curl localhost:8080/slow -HAUTH="foo"` + #### Pending Features -- Concurrent tracing support. - Thrift support - Additional clients - Pluggable samplers diff --git a/app/Main.hs b/app/Main.hs deleted file mode 100644 --- a/app/Main.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -module Main where - -import Servant.Tracing ( getInstructions, WithTracing) -import Tracing.Core (recordSpan,TracingInstructions(..), SpanRelationTag(..), Tracer(..), MonadTracer(..), SpanId(..), - TraceId(..), debugPrintSpan) -import Tracing.Zipkin (publishZipkin) - -import Control.Concurrent (threadDelay, forkIO) -import Control.Monad (forever, mapM_) -import Control.Monad.Trans (MonadIO, liftIO) -import Control.Monad.Trans.Control (MonadBaseControl) -import Control.Monad.Reader (ReaderT(..), ask, MonadReader) -import Data.IORef (IORef, newIORef, atomicModifyIORef') -import Data.Maybe (maybe) -import Data.Proxy (Proxy(..)) -import Data.Foldable (toList) -import Data.ByteString.Char8 as BS -import Servant -import Servant.Server -import System.Environment (lookupEnv, getEnv) -import qualified Data.Text as T -import Network.Wai.Handler.Warp (run) -import Network.HTTP.Client (Manager, newManager, defaultManagerSettings, responseStatus, responseBody) - - -main :: IO () -main = do - debug <- maybe False (== "TRUE") <$> lookupEnv "TRACE_DEBUG" - destinationPath <- getEnv "TRACING_ENDPOINT" - svcName <- T.pack <$> getEnv "TRACING_SERVICE" - httpManager <- newManager defaultManagerSettings - cell <- newIORef [] - let tracer = Tracer cell svcName - forkIO $ publishLoop destinationPath httpManager tracer - run 8080 . serve (Proxy :: Proxy ExampleAPI) $ server tracer - - -publishLoop :: - String - -> Manager - -> Tracer - -> IO () -publishLoop destination manager (Tracer {spanBuffer}) = forever $ do - threadDelay 5000000 - buffer <- atomicModifyIORef' spanBuffer (\b -> ([], b)) - mResp <- publishZipkin destination manager $ toList buffer - case mResp of - Nothing -> pure () - Just resp -> do - print $ "Ran Loop " ++ (show $ responseStatus resp) ++ " " ++ (show . fmap debugPrintSpan $ toList buffer) - print $ " " ++ (T.unpack $ responseBody resp) - - - --- --- API Definition --- - -type ExampleAPI = - WithTracing :> MyAPI - -type MyAPI = - Header "Auth" T.Text :> - ( - "fast" :> Get '[JSON] Int - :<|> - "slow" :> Get '[JSON] T.Text - ) - - --- --- Server logic --- -server :: Tracer -> Server (WithTracing :> MyAPI) -server tracer inst auth = - runFast - :<|> - runSlow - where - loadCtx = do - instructions <- getInstructions True inst - currSpan <- liftIO $ newIORef (spanId instructions) - pure Ctx { - tracer, - currSpan, - instructions - } - runFast = do - ctx <- loadCtx - runStack ctx $ - recordSpan (const Child <$> inst) [] "Run Fast" . liftIO $ - threadDelay 1000000 *> pure 42 - runSlow = do - ctx <- loadCtx - runStack ctx $ - recordSpan (const Child <$> inst) [] "Run Slow" $ do - liftIO $ threadDelay 500000 - let action = liftIO $ threadDelay 1500000 *> pure "Boo" - recordSpan (Just Child) [] "Slow Child" action - -runStack :: Ctx -> ReaderT Ctx Handler a -> Handler a -runStack ctx action = runReaderT action ctx - -data Ctx = Ctx { - tracer :: Tracer, - currSpan :: IORef SpanId, - instructions :: TracingInstructions - } - -instance (Monad m, MonadBaseControl IO m, MonadIO m, MonadReader Ctx m) => MonadTracer m where - getTracer = tracer <$> ask - currentTrace = (traceId . instructions) <$> ask - currentSpan = currSpan <$> ask - isDebug = (debug . instructions) <$> ask diff --git a/servant-tracing.cabal b/servant-tracing.cabal --- a/servant-tracing.cabal +++ b/servant-tracing.cabal @@ -1,11 +1,11 @@ name: servant-tracing -version: 0.1.0.2 +version: 0.2.0.0 description: Please see the README on Github at homepage: https://github.com/ChrisCoffey/haskell-opentracing-light#readme bug-reports: https://github.com/ChrisCoffey/haskell-opentracing-light/issues author: Chris Coffey -maintainer: chris@foldl.io -copyright: 2018 Chris Coffey +maintainer: chris@coffey.dev +copyright: 2018-2021 Chris Coffey license: MIT license-file: LICENSE build-type: Simple @@ -22,13 +22,12 @@ library default-extensions: DataKinds FlexibleContexts ScopedTypeVariables OverloadedStrings ViewPatterns NamedFieldPuns KindSignatures RecordWildCards ConstraintKinds TypeSynonymInstances FlexibleInstances - DuplicateRecordFields GeneralizedNewtypeDeriving InstanceSigs TypeFamilies + DuplicateRecordFields GeneralizedNewtypeDeriving InstanceSigs TypeFamilies MultiParamTypeClasses hs-source-dirs: src build-depends: base >=4.7 && <5 , servant - , servant-server , containers , unordered-containers , time @@ -43,8 +42,9 @@ , monad-control , lifted-base , http-api-data - , aeson + , aeson >= 2.0.1.0 && < 3 , http-client + , http-types exposed-modules: Tracing.Core , Tracing.Zipkin @@ -53,32 +53,6 @@ -- other-modules: default-language: Haskell2010 -executable servant-tracing-example - main-is: Main.hs - hs-source-dirs: - app - default-extensions: DataKinds FlexibleContexts ScopedTypeVariables OverloadedStrings ViewPatterns NamedFieldPuns - KindSignatures RecordWildCards ConstraintKinds TypeSynonymInstances FlexibleInstances - DuplicateRecordFields GeneralizedNewtypeDeriving InstanceSigs TypeFamilies TypeOperators - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: - base >=4.7 && <5 - , servant-tracing - , servant - , servant-server - , bytestring - , mtl - , text - , transformers - , containers - , wai - , monad-control - , lifted-base - , warp - , async - , http-client - default-language: Haskell2010 - test-suite servant-tracing-test type: exitcode-stdio-1.0 main-is: Spec.hs @@ -99,7 +73,7 @@ , tasty , tasty-quickcheck , tasty-hunit - , aeson + , aeson >= 2.0.1.0 && < 3 , containers , time other-modules: diff --git a/src/Servant/Tracing.hs b/src/Servant/Tracing.hs --- a/src/Servant/Tracing.hs +++ b/src/Servant/Tracing.hs @@ -1,6 +1,5 @@ {-# LANGUAGE RankNTypes #-} module Servant.Tracing ( - ServantTracingT, WithTracing, TracingInstructions(..), instructionsToHeader, @@ -18,13 +17,11 @@ import Data.Bits (testBit, (.|.)) import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid ((<>)) -import Servant -import Servant.Server +import Servant.API.Header (Header) import System.Random (randomRIO) import Web.HttpApiData (FromHttpApiData(..)) -- | Constrain the 'ServerT''s base monad such that it provides an instance of 'MonadTracer' -type ServantTracingT api m = (MonadIO m, MonadTracer m) => ServerT api m type WithTracing = Header "uber-trace-id" TracingInstructions diff --git a/src/Tracing/Core.hs b/src/Tracing/Core.hs --- a/src/Tracing/Core.hs +++ b/src/Tracing/Core.hs @@ -12,6 +12,7 @@ Tracer(..), TracingInstructions(..), MonadTracer(..), + HasSpanId(..), ToSpanTag(..), Tag(..), @@ -22,6 +23,7 @@ import Control.Arrow ((&&&)) import Control.Exception.Lifted (bracket) import Control.Monad.Trans (liftIO, MonadIO) +import Control.Monad.Reader (MonadReader, ask, local) import Control.Monad.Trans.Control (MonadBaseControl) import Data.Text (Text) import qualified Data.Text as T @@ -51,20 +53,26 @@ newtype TraceId = TraceId Int64 deriving (Eq, Ord, Show, FromHttpApiData) +class HasSpanId a where + getSpanId :: a -> SpanId + setSpanId :: a -> SpanId -> a + -- | Indicates that the current monad can provide a 'Tracer' and related context. -- It assumes some form of environment. While this exposes some mutable state, all -- of it is hidden away behind the `recordSpan` api. -class Monad m => MonadTracer m where +class (Monad m, HasSpanId r, MonadReader r m) => MonadTracer m r where getTracer :: m Tracer -- ^ 'Tracer' is global to the process currentTrace :: m TraceId -- ^ Set during the initial request from the outside world, this is propagated across all nodes in the call - currentSpan :: m (IORef SpanId) -- ^ Set via 'recordSpan' isDebug :: m Bool -- ^ Set during the initial request from the outside world, this is propagated across all nodes in the call + currentSpan :: m SpanId + currentSpan = getSpanId <$> ask + -- | Wraps a computation & writes it to the 'Tracer''s IORef. To start a new top-level span, and therefore -- a new trace, call this function with *spanType* == 'Nothing'. Otherwise, this will create a child span. -- -- Doesn't support parallel computations yet -recordSpan :: (MonadIO m, MonadBaseControl IO m, MonadTracer m) => +recordSpan :: (MonadIO m, MonadBaseControl IO m, MonadTracer m r) => Maybe SpanRelationTag -> [Tag] -> OpName @@ -72,8 +80,7 @@ -> m a recordSpan spanType tags opName action = do Tracer {svcName=serviceName, spanBuffer} <- getTracer - currentSpanCell <- currentSpan - activeSpanId <- liftIO $ readIORef currentSpanCell + activeSpanId <- currentSpan traceId <- currentTrace debug <- isDebug @@ -97,21 +104,21 @@ debug, serviceName } - liftIO $ atomicModifyIORef' currentSpanCell (const (newSpanId, ())) - pure $ ActiveSpan makeSpan + pure $ ActiveSpan loggedSpanId makeSpan - closeSpan (ActiveSpan finishSpan) = do + 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, ())) + runAction (ActiveSpan spanId _) = + local (`setSpanId` spanId) action + bracket startSpan closeSpan - (const action) - + runAction where -- When this is a top level span, there should be no SpanRelationTag. These two functions work -- together to ensure the spans nest properly @@ -135,8 +142,8 @@ sample :: !Bool } deriving (Eq, Show) -newtype ActiveSpan = - ActiveSpan {finishSpan :: UTCTime -> Span} +data ActiveSpan = + ActiveSpan {asid :: SpanId, finishSpan :: UTCTime -> Span} -- | Global context required for tracing. The `spanBuffer` should be manually drained by library users. data Tracer = diff --git a/src/Tracing/DataDog.hs b/src/Tracing/DataDog.hs --- a/src/Tracing/DataDog.hs +++ b/src/Tracing/DataDog.hs @@ -18,9 +18,12 @@ import qualified Data.Text.Encoding as T import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as LBSC8 import qualified Data.ByteString.Lex.Integral as BS -import qualified Data.HashMap.Strict as HM import Network.HTTP.Client +import Network.HTTP.Types.Header (Header) +import Data.Aeson.Types (ToJSON(toJSON)) +import qualified Data.Map as Map -- | Publish 'Span' in the . No call is made @@ -28,21 +31,25 @@ publishDataDog :: MonadIO m => String -- ^ The address of the backend server -> Manager + -> [Header] -> [Span] -- ^ The traced spans to send to a DataDog backend -> m (Maybe (Response T.Text)) -publishDataDog _ _ [] = pure Nothing -publishDataDog destination manager spans = - liftIO . fmap (Just . fmap decode) $ httpLbs zipkinReq manager +publishDataDog _ _ _ [] = pure Nothing +publishDataDog destination manager additionalHeaders spans = + liftIO . fmap (Just . fmap decode) $ httpLbs ddReq manager where decode = T.decodeUtf8 . LBS.toStrict req = parseRequest_ destination body = RequestBodyLBS . encode $ DataDogSpan <$> spans - zipkinReq = req { method = "POST", requestBody = body, requestHeaders = [("content-type", "application/json")]} + ddReq = req { method = "POST", + requestBody = body, + requestHeaders = [("content-type", "application/json")] <> additionalHeaders + } newtype DataDogSpan = DataDogSpan Span instance ToJSON DataDogSpan where toJSON (DataDogSpan span) = object $ [ - "trace_id" .= (unTrace . traceId $ context span), + "trace_id" .= (unTrace . traceId $ context span), "span_id" .= (unSpan . spanId $ context span), "name" .= unOp (operationName span), "resource" .= unOp (operationName span), @@ -58,7 +65,6 @@ unOp (OpName n) = n unSpan (SpanId sid) = sid unTrace (TraceId tid) = tid - parentId :: [SpanRelation] -> [(T.Text, Value)] parentId (ChildOf ctx:_) = ["parent_id" .= (unSpan $ spanId ctx)] parentId (FollowsFrom ctx:_) = ["parent_id" .= (unSpan $ spanId ctx)] parentId _ = [] diff --git a/src/Tracing/Zipkin.hs b/src/Tracing/Zipkin.hs --- a/src/Tracing/Zipkin.hs +++ b/src/Tracing/Zipkin.hs @@ -58,7 +58,6 @@ zipkinFormatId = padLeft 16 . T.pack . BS.unpack . fromMaybe "-1" unTrace (TraceId t) = zipkinFormatId $ BS.packHexadecimal t unSpan (SpanId s) = zipkinFormatId $ BS.packHexadecimal s - parentId :: [SpanRelation] -> [(T.Text, Value)] parentId (ChildOf ctx:_) = ["parentId" .= (unSpan $ spanId ctx)] parentId (FollowsFrom ctx:_) = ["parentId" .= (unSpan $ spanId ctx)] parentId _ = [] diff --git a/test/Tracing/CoreSpec.hs b/test/Tracing/CoreSpec.hs --- a/test/Tracing/CoreSpec.hs +++ b/test/Tracing/CoreSpec.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NamedFieldPuns, OverloadedStrings, UndecidableInstances, DuplicateRecordFields, FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns, OverloadedStrings, UndecidableInstances, DuplicateRecordFields, FlexibleInstances, MultiParamTypeClasses #-} module Tracing.CoreSpec ( coreProps, @@ -93,10 +93,10 @@ ctx <- newContext flip runReaderT ctx . recordSpan Nothing [] "Foo" $ recordSpan (Just Child) [] "Bar" $ - recordSpan (Just Child) [] "Baz" + recordSpan (Just Child) [] "Baz" $ pure (7 + 8) -- This test will break if 'recordSpan' changes significantly [x, y, z] <- readIORef . spanBuffer $ tracer ctx - let pid = + let pid = x ((sid $ context x) /= (sid $ context y)) @? "Sibling spans must have different ids" -} ] @@ -104,7 +104,7 @@ newContext :: IO Ctx newContext = do cell <- newIORef [] - currSpan <- newIORef $ SpanId 1234 + let currSpan = SpanId 1234 pure Ctx { tracer = Tracer cell "UNIT TESTING", currSpan = currSpan, @@ -122,13 +122,16 @@ data Ctx = Ctx { tracer :: Tracer, - currSpan :: IORef SpanId, + currSpan :: SpanId, dbg :: Bool, currTrace :: TraceId } -instance (Monad m, MonadBaseControl IO m, MonadIO m, MonadReader Ctx m) => MonadTracer m where +instance HasSpanId Ctx where + getSpanId = currSpan + setSpanId c s = c {currSpan = s} + +instance (Monad m, MonadBaseControl IO m, MonadIO m, MonadReader Ctx m) => MonadTracer m Ctx where getTracer = tracer <$> ask currentTrace = currTrace <$> ask - currentSpan = currSpan <$> ask isDebug = dbg <$> ask