├── .travis.yml ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── app └── Main.hs ├── servant-tracing.cabal ├── src ├── Servant │ └── Tracing.hs └── Tracing │ ├── Core.hs │ ├── DataDog.hs │ └── Zipkin.hs ├── stack.yaml └── test ├── DataDog └── ClientSpec.hs ├── Instances.hs ├── Servant └── TracingSpec.hs ├── Spec.hs ├── Tracing └── CoreSpec.hs └── Zipkin └── ClientSpec.hs /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: false 2 | 3 | cache: 4 | directories: 5 | - $HOME/.stack 6 | 7 | before_install: 8 | # Download and unpack the stack executable 9 | - mkdir -p ~/.local/bin 10 | - export PATH=$HOME/.local/bin:$PATH 11 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 12 | 13 | install: 14 | - stack --no-terminal --install-ghc test --only-dependencies 15 | 16 | script: 17 | - stack --no-terminal test --haddock --no-haddock-deps 18 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for servant-tracing 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # servant-tracing 2 | 3 | [![Build Status](https://travis-ci.org/ChrisCoffey/haskell-opentracing-light.svg?branch=master)](https://travis-ci.org/ChrisCoffey/haskell-opentracing-light) 4 | 5 | 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. 6 | 7 | 8 | ### Using the library 9 | 10 | The OpenTracing standard revolves around a single function, `recordSpan`. `recordSpan` is responsible for creating new spans (see the standard for the definition of a span) and ensuring child spans use the new id. In order to properly build this tree of calls library users must provide the necessary environment via a `MonadTracer` instance (see haddocks). Library users are responsible for defining their own publish loop. There is a default `Zipkin` publisher in `Tracing.Zipkin` which works with Jaeger & Zipkin, but the loop to drain the `spanBuffer` must be provided by the user. 11 | 12 | ``` 13 | foo :: (MonadIO m, MonadTracer m) => 14 | Int 15 | -> m String 16 | foo str = recordSpan 17 | Nothing 18 | [Tag "Ultimate Answer to Life, The Universe and Everything", Tag 42] 19 | "Compute Ultimate Question" 20 | $ pure "Oops" 21 | ``` 22 | 23 | The code above logs a new span to the `spanBuffer`, where it will sit until published. If it turns out that `foo` is called from an active span, then it will be recorded as a child of said higher span. 24 | 25 | ### Testing Locally with the Demo App 26 | 27 | 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: 28 | - *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. 29 | - *TRACING_SERVICE*: a `String` name for your service 30 | 31 | 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"` 32 | 33 | 34 | #### Pending Features 35 | - Thrift support 36 | - Additional clients 37 | - Pluggable samplers 38 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances, MultiParamTypeClasses #-} 2 | module Main where 3 | 4 | import Servant.Tracing ( getInstructions, WithTracing) 5 | import Tracing.Core (recordSpan,TracingInstructions(..), SpanRelationTag(..), Tracer(..), MonadTracer(..), SpanId(..), 6 | TraceId(..), debugPrintSpan, HasSpanId(..)) 7 | import Tracing.Zipkin (publishZipkin) 8 | 9 | import Control.Concurrent (threadDelay, forkIO) 10 | import Control.Monad (forever, mapM_) 11 | import Control.Monad.Trans (MonadIO, liftIO) 12 | import Control.Monad.Trans.Control (MonadBaseControl) 13 | import Control.Monad.Reader (ReaderT(..), ask, MonadReader) 14 | import Data.IORef (IORef, newIORef, atomicModifyIORef') 15 | import Data.Maybe (maybe) 16 | import Data.Proxy (Proxy(..)) 17 | import Data.Foldable (toList) 18 | import Data.ByteString.Char8 as BS 19 | import Servant 20 | import Servant.Server 21 | import System.Environment (lookupEnv, getEnv) 22 | import qualified Data.Text as T 23 | import Network.Wai.Handler.Warp (run) 24 | import Network.HTTP.Client (Manager, newManager, defaultManagerSettings, responseStatus, responseBody) 25 | 26 | 27 | main :: IO () 28 | main = do 29 | debug <- maybe False (== "TRUE") <$> lookupEnv "TRACE_DEBUG" 30 | destinationPath <- getEnv "TRACING_ENDPOINT" 31 | svcName <- T.pack <$> getEnv "TRACING_SERVICE" 32 | httpManager <- newManager defaultManagerSettings 33 | cell <- newIORef [] 34 | let tracer = Tracer cell svcName 35 | forkIO $ publishLoop destinationPath httpManager tracer 36 | run 8080 . serve (Proxy :: Proxy ExampleAPI) $ server tracer 37 | 38 | 39 | publishLoop :: 40 | String 41 | -> Manager 42 | -> Tracer 43 | -> IO () 44 | publishLoop destination manager (Tracer {spanBuffer}) = forever $ do 45 | threadDelay 5000000 46 | buffer <- atomicModifyIORef' spanBuffer (\b -> ([], b)) 47 | mResp <- publishZipkin destination manager $ toList buffer 48 | case mResp of 49 | Nothing -> pure () 50 | Just resp -> do 51 | print $ "Ran Loop " ++ (show $ responseStatus resp) ++ " " ++ (show . fmap debugPrintSpan $ toList buffer) 52 | print $ " " ++ (T.unpack $ responseBody resp) 53 | 54 | 55 | 56 | -- 57 | -- API Definition 58 | -- 59 | 60 | type ExampleAPI = 61 | WithTracing :> MyAPI 62 | 63 | type MyAPI = 64 | Header "Auth" T.Text :> 65 | ( 66 | "fast" :> Get '[JSON] Int 67 | :<|> 68 | "slow" :> Get '[JSON] T.Text 69 | ) 70 | 71 | 72 | -- 73 | -- Server logic 74 | -- 75 | server :: Tracer -> Server (WithTracing :> MyAPI) 76 | server tracer inst auth = 77 | runFast 78 | :<|> 79 | runSlow 80 | where 81 | loadCtx = do 82 | instructions <- getInstructions True inst 83 | let currSpan = spanId instructions 84 | pure Ctx { 85 | tracer, 86 | currSpan, 87 | instructions 88 | } 89 | runFast = do 90 | ctx <- loadCtx 91 | runStack ctx $ 92 | recordSpan (const Child <$> inst) [] "Run Fast" . liftIO $ 93 | threadDelay 1000000 *> pure 42 94 | runSlow = do 95 | ctx <- loadCtx 96 | runStack ctx $ 97 | recordSpan (const Child <$> inst) [] "Run Slow" $ do 98 | liftIO $ threadDelay 500000 99 | let action = liftIO $ threadDelay 1500000 *> pure "Boo" 100 | recordSpan (Just Child) [] "Slow Child" action 101 | 102 | runStack :: Ctx -> ReaderT Ctx Handler a -> Handler a 103 | runStack ctx action = runReaderT action ctx 104 | 105 | data Ctx = Ctx { 106 | tracer :: Tracer, 107 | currSpan :: SpanId, 108 | instructions :: TracingInstructions 109 | } 110 | 111 | instance HasSpanId Ctx where 112 | getSpanId = currSpan 113 | setSpanId c s = c {currSpan = s } 114 | 115 | instance (Monad m, MonadBaseControl IO m, MonadIO m, MonadReader Ctx m) => MonadTracer m Ctx where 116 | getTracer = tracer <$> ask 117 | currentTrace = (traceId . instructions) <$> ask 118 | isDebug = (debug . instructions) <$> ask 119 | -------------------------------------------------------------------------------- /servant-tracing.cabal: -------------------------------------------------------------------------------- 1 | name: servant-tracing 2 | version: 0.2.0.0 3 | description: Please see the README on Github at 4 | homepage: https://github.com/ChrisCoffey/haskell-opentracing-light#readme 5 | bug-reports: https://github.com/ChrisCoffey/haskell-opentracing-light/issues 6 | author: Chris Coffey 7 | maintainer: chris@coffey.dev 8 | copyright: 2018-2021 Chris Coffey 9 | license: MIT 10 | license-file: LICENSE 11 | build-type: Simple 12 | cabal-version: >= 1.10 13 | 14 | extra-source-files: 15 | ChangeLog.md 16 | README.md 17 | 18 | source-repository head 19 | type: git 20 | location: https://github.com/ChrisCoffey/haskell-opentracing-light 21 | 22 | library 23 | default-extensions: DataKinds FlexibleContexts ScopedTypeVariables OverloadedStrings ViewPatterns NamedFieldPuns 24 | KindSignatures RecordWildCards ConstraintKinds TypeSynonymInstances FlexibleInstances 25 | DuplicateRecordFields GeneralizedNewtypeDeriving InstanceSigs TypeFamilies MultiParamTypeClasses 26 | hs-source-dirs: 27 | src 28 | build-depends: 29 | base >=4.7 && <5 30 | , servant 31 | , containers 32 | , unordered-containers 33 | , time 34 | , wai 35 | , bytestring 36 | , bytestring-lexing 37 | , hashable 38 | , mtl 39 | , random 40 | , text 41 | , async 42 | , monad-control 43 | , lifted-base 44 | , http-api-data 45 | , aeson >= 2.0.1.0 && < 3 46 | , http-client 47 | , http-types 48 | exposed-modules: 49 | Tracing.Core 50 | , Tracing.Zipkin 51 | , Tracing.DataDog 52 | , Servant.Tracing 53 | -- other-modules: 54 | default-language: Haskell2010 55 | 56 | test-suite servant-tracing-test 57 | type: exitcode-stdio-1.0 58 | main-is: Spec.hs 59 | hs-source-dirs: 60 | test 61 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 62 | build-depends: 63 | base >=4.7 && <5 64 | , servant-tracing 65 | , http-api-data 66 | , transformers 67 | , containers 68 | , monad-control 69 | , text 70 | , mtl 71 | , QuickCheck 72 | , HUnit 73 | , tasty 74 | , tasty-quickcheck 75 | , tasty-hunit 76 | , aeson >= 2.0.1.0 && < 3 77 | , containers 78 | , time 79 | other-modules: 80 | Servant.TracingSpec, 81 | Instances, 82 | Zipkin.ClientSpec, 83 | DataDog.ClientSpec, 84 | Tracing.CoreSpec 85 | default-language: Haskell2010 86 | -------------------------------------------------------------------------------- /src/Servant/Tracing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | module Servant.Tracing ( 3 | WithTracing, 4 | TracingInstructions(..), 5 | instructionsToHeader, 6 | getInstructions 7 | ) where 8 | 9 | import Tracing.Core (Tracer, TraceId(..), SpanId(..), MonadTracer, TracingInstructions(..)) 10 | 11 | import Control.Arrow (first) 12 | import Control.Monad.Trans (liftIO, MonadIO) 13 | import qualified Data.Text as T 14 | import qualified Data.ByteString.Char8 as BS 15 | import qualified Data.ByteString.Lex.Integral as BS 16 | import Data.Text.Read(hexadecimal) 17 | import Data.Bits (testBit, (.|.)) 18 | import Data.Maybe (catMaybes, fromMaybe) 19 | import Data.Monoid ((<>)) 20 | import Servant.API.Header (Header) 21 | import System.Random (randomRIO) 22 | import Web.HttpApiData (FromHttpApiData(..)) 23 | 24 | -- | Constrain the 'ServerT''s base monad such that it provides an instance of 'MonadTracer' 25 | type WithTracing = Header "uber-trace-id" TracingInstructions 26 | 27 | 28 | -- | Jaeger format: http://jaeger.readthedocs.io/en/latest/client_libraries/#propagation-format 29 | -- This allows the trace backend to reassemble downstream traces. 30 | instructionsToHeader :: TracingInstructions -> T.Text 31 | instructionsToHeader TracingInstructions {traceId=(TraceId tid), spanId, parentSpanId, sample, debug} = 32 | toField tid<>":"<> 33 | (toField $ unSpanId spanId) <> ":"<> 34 | (fromMaybe "" $ (toField . unSpanId) <$> parentSpanId) <> ":" <> 35 | (T.pack $ show setFlags) 36 | where 37 | unSpanId (SpanId sid) = sid 38 | toField = T.pack . BS.unpack . fromMaybe "" . BS.packHexadecimal 39 | setFlags :: Int 40 | setFlags = (if debug then 2 else 0) .|. (if sample then 1 else 0) .|. 0 41 | 42 | 43 | instance FromHttpApiData TracingInstructions where 44 | parseUrlPiece :: 45 | T.Text 46 | -> Either T.Text TracingInstructions 47 | parseUrlPiece raw = 48 | case T.splitOn ":" raw of 49 | [rawTraceId, rawSpanId, rawParentId, flags] -> let 50 | res = do 51 | traceId <- TraceId . fromIntegral . fst <$> hexadecimal rawTraceId 52 | spanId <- SpanId . fromIntegral . fst <$> hexadecimal rawSpanId 53 | let resolvedPid = if T.null rawParentId 54 | then pure (Nothing, "") 55 | else first Just <$> hexadecimal rawParentId 56 | parentId <- fmap (SpanId . fromIntegral) . fst <$> resolvedPid 57 | flagField <- fromIntegral . fst <$> hexadecimal flags 58 | let [sample, debug]= [sampleFlag, debugFlag] <*> [flagField] 59 | pure TracingInstructions { 60 | traceId = traceId, 61 | spanId = spanId, 62 | parentSpanId = parentId, 63 | sample = sample, 64 | debug = debug 65 | } 66 | in case res of 67 | Left err -> Left $ T.pack err 68 | Right val -> Right val 69 | _ -> Left $ raw <> " is not a valid uber-trace-id header" 70 | where 71 | sampleFlag :: Int -> Bool 72 | sampleFlag = (`testBit` 0) 73 | debugFlag :: Int -> Bool 74 | debugFlag = (`testBit` 1) 75 | 76 | 77 | -- TODO write a monad that wraps servant & determines if it should sample or not. Takes a sampling determinant. Only evaluates if the header is not present 78 | 79 | -- | In the event that there are no 'TracingInstructions' for this call, generate new instructions. 80 | -- 81 | -- This has a 82 | getInstructions :: MonadIO m => 83 | Bool 84 | -> Maybe TracingInstructions 85 | -> m TracingInstructions 86 | getInstructions debug Nothing = do 87 | newTraceId <- liftIO $ randomRIO (0, maxBound) 88 | newSpanId <- liftIO $ randomRIO (0, maxBound) 89 | sample <- liftIO $ randomRIO (0, 1000) 90 | pure TracingInstructions { 91 | traceId = TraceId newTraceId, 92 | spanId = SpanId newSpanId, 93 | parentSpanId = Nothing, 94 | debug, 95 | sample = sample == (1::Int) 96 | } 97 | getInstructions _ (Just inst) = pure inst 98 | -------------------------------------------------------------------------------- /src/Tracing/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification, RankNTypes, UndecidableInstances #-} 2 | 3 | module Tracing.Core ( 4 | Span(..), 5 | SpanRelation(..), 6 | SpanRelationTag(..), 7 | SpanContext(..), 8 | SpanTag(..), 9 | OpName(..), 10 | SpanId(..), 11 | TraceId(..), 12 | Tracer(..), 13 | TracingInstructions(..), 14 | MonadTracer(..), 15 | HasSpanId(..), 16 | ToSpanTag(..), 17 | Tag(..), 18 | 19 | recordSpan, 20 | debugPrintSpan 21 | ) where 22 | 23 | import Control.Arrow ((&&&)) 24 | import Control.Exception.Lifted (bracket) 25 | import Control.Monad.Trans (liftIO, MonadIO) 26 | import Control.Monad.Reader (MonadReader, ask, local) 27 | import Control.Monad.Trans.Control (MonadBaseControl) 28 | import Data.Text (Text) 29 | import qualified Data.Text as T 30 | import qualified Data.Text.Encoding as T 31 | import qualified Data.ByteString.Lazy as BSL 32 | import Data.Time.Clock (NominalDiffTime, UTCTime, getCurrentTime, diffUTCTime) 33 | import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds) 34 | import Data.Int 35 | import Data.Aeson (ToJSON, encode) 36 | import Data.Maybe (isJust) 37 | import Data.Monoid ((<>)) 38 | import Data.String (IsString) 39 | import System.Random (randomRIO) 40 | import Data.IORef (IORef, atomicModifyIORef',readIORef) 41 | import qualified Data.Map.Strict as M 42 | import Web.HttpApiData (FromHttpApiData) 43 | 44 | -- | Human-readable name for the span 45 | newtype OpName = OpName Text 46 | deriving (Eq, Ord, Show, IsString) 47 | 48 | -- | An opaque & unique identifier for a trace segment, called a Span 49 | newtype SpanId = SpanId Int64 50 | deriving (Eq, Ord, Show, FromHttpApiData) 51 | 52 | -- | An opaque & unique identifier for a logical operation. Traces are composed of many 'Span's 53 | newtype TraceId = TraceId Int64 54 | deriving (Eq, Ord, Show, FromHttpApiData) 55 | 56 | class HasSpanId a where 57 | getSpanId :: a -> SpanId 58 | setSpanId :: a -> SpanId -> a 59 | 60 | -- | Indicates that the current monad can provide a 'Tracer' and related context. 61 | -- It assumes some form of environment. While this exposes some mutable state, all 62 | -- of it is hidden away behind the `recordSpan` api. 63 | class (Monad m, HasSpanId r, MonadReader r m) => MonadTracer m r where 64 | getTracer :: m Tracer -- ^ 'Tracer' is global to the process 65 | currentTrace :: m TraceId -- ^ Set during the initial request from the outside world, this is propagated across all nodes in the call 66 | isDebug :: m Bool -- ^ Set during the initial request from the outside world, this is propagated across all nodes in the call 67 | 68 | currentSpan :: m SpanId 69 | currentSpan = getSpanId <$> ask 70 | 71 | -- | Wraps a computation & writes it to the 'Tracer''s IORef. To start a new top-level span, and therefore 72 | -- a new trace, call this function with *spanType* == 'Nothing'. Otherwise, this will create a child span. 73 | -- 74 | -- Doesn't support parallel computations yet 75 | recordSpan :: (MonadIO m, MonadBaseControl IO m, MonadTracer m r) => 76 | Maybe SpanRelationTag 77 | -> [Tag] 78 | -> OpName 79 | -> m a 80 | -> m a 81 | recordSpan spanType tags opName action = do 82 | Tracer {svcName=serviceName, spanBuffer} <- getTracer 83 | activeSpanId <- currentSpan 84 | traceId <- currentTrace 85 | debug <- isDebug 86 | 87 | -- generates a thunk that completes once the action provided to 'recordSpan' finishes. 88 | -- While this is running, there is a new "activeSpanId" that any children will use. Nested calls 89 | -- generate a stack of spans. 90 | let startSpan = do 91 | now <- liftIO getCurrentTime 92 | newSpanId <- fmap SpanId . liftIO $ randomRIO (0, maxBound) 93 | let loggedSpanId = resolveSpanId activeSpanId newSpanId 94 | rel = newSpanRelation traceId activeSpanId 95 | makeSpan ts = 96 | Span { 97 | operationName = opName, 98 | context = SpanContext traceId loggedSpanId, 99 | timestamp = utcTimeToPOSIXSeconds now, 100 | relations = rel, 101 | tags = M.fromList $ (\(Tag key t) -> (key, toSpanTag t) ) <$> tags, 102 | baggage = M.empty, -- TODO Allow adding these 103 | duration = diffUTCTime ts now, 104 | debug, 105 | serviceName 106 | } 107 | pure $ ActiveSpan loggedSpanId makeSpan 108 | 109 | 110 | closeSpan (ActiveSpan _ finishSpan) = do 111 | now <- liftIO getCurrentTime 112 | let span = finishSpan now 113 | sid = spanId (context span :: SpanContext) 114 | liftIO $ atomicModifyIORef' spanBuffer (\xs -> (span:xs, ())) 115 | 116 | runAction (ActiveSpan spanId _) = 117 | local (`setSpanId` spanId) action 118 | 119 | bracket startSpan 120 | closeSpan 121 | runAction 122 | where 123 | -- When this is a top level span, there should be no SpanRelationTag. These two functions work 124 | -- together to ensure the spans nest properly 125 | resolveSpanId activeSpanId newSpanId = 126 | if isJust spanType 127 | then newSpanId 128 | else activeSpanId 129 | newSpanRelation traceId activeSpanId = 130 | case spanType of 131 | Just Child -> [ChildOf $ SpanContext traceId activeSpanId] 132 | Just Follows -> [FollowsFrom $ SpanContext traceId activeSpanId] 133 | Nothing -> [] 134 | 135 | -- | Instructions that are specific to a single trace 136 | data TracingInstructions = 137 | TracingInstructions { 138 | traceId :: !TraceId, 139 | spanId :: !SpanId, 140 | parentSpanId :: !(Maybe SpanId), 141 | debug :: !Bool, 142 | sample :: !Bool 143 | } deriving (Eq, Show) 144 | 145 | data ActiveSpan = 146 | ActiveSpan {asid :: SpanId, finishSpan :: UTCTime -> Span} 147 | 148 | -- | Global context required for tracing. The `spanBuffer` should be manually drained by library users. 149 | data Tracer = 150 | Tracer { 151 | spanBuffer :: IORef [Span], 152 | svcName :: T.Text 153 | } 154 | 155 | -- | Uniquely identifies a given 'Span' & points to its encompasing trace 156 | data SpanContext = 157 | SpanContext { 158 | traceId :: !TraceId, 159 | spanId :: !SpanId 160 | } deriving (Eq, Show) 161 | 162 | -- | Spans may be top level, a child, or logically follow from a given span. 163 | data SpanRelation = 164 | ChildOf !SpanContext | FollowsFrom !SpanContext 165 | deriving (Eq, Show) 166 | 167 | -- | Indicates the type of relation this span represents 168 | data SpanRelationTag = Child | Follows 169 | 170 | -- | A timed section of code with a logical name and 'SpanContext'. Individual spans will be reconstructed by an 171 | -- OpenTracing backend into a single trace. 172 | data Span = Span { 173 | operationName :: !OpName, 174 | context :: !SpanContext, 175 | timestamp :: !POSIXTime, 176 | duration :: !NominalDiffTime, 177 | relations :: ![SpanRelation], 178 | tags :: !(M.Map Text SpanTag), 179 | baggage:: !(M.Map Text Text), 180 | debug :: !Bool, 181 | serviceName :: !Text 182 | } deriving Show 183 | 184 | -- | Dump the details of a span. Used for debugging or logging 185 | debugPrintSpan :: 186 | Span 187 | -> Text 188 | debugPrintSpan span = 189 | "Span: " <> 190 | "id ["<>(unSpan $ spanId (context span :: SpanContext))<>"] "<> 191 | "op ["<>(unOp $ operationName span)<>"] "<> 192 | "duration ["<>(T.pack . show $ duration span)<> "] "<> 193 | "relations "<>(T.pack . show $ relations span) 194 | where 195 | unOp (OpName o) = o 196 | unSpan (SpanId s) = T.pack $ show s 197 | 198 | -- | Used to embed additional information into a Span for consumption & viewing in a tracing backend 199 | data SpanTag 200 | = TagString !Text 201 | | TagBool !Bool 202 | | TagInt !Int64 203 | | TagDouble !Double 204 | deriving (Eq, Show) 205 | 206 | -- | Allows for easily representing multiple types in a tag list 207 | data Tag = forall a. ToSpanTag a => Tag T.Text a 208 | 209 | -- | The type in question may be converted into a 'SpanTag' 210 | class ToSpanTag a where 211 | toSpanTag :: a -> SpanTag 212 | 213 | instance ToSpanTag SpanTag where 214 | toSpanTag = id 215 | 216 | instance ToJSON a => ToSpanTag a where 217 | toSpanTag = TagString . T.decodeUtf8 . BSL.toStrict . encode 218 | -------------------------------------------------------------------------------- /src/Tracing/DataDog.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Tracing.DataDog ( 4 | publishDataDog, 5 | DataDogSpan(..) 6 | ) where 7 | 8 | import Tracing.Core (Span(..), SpanId(..), OpName(..), TraceId(..), SpanContext(..), 9 | SpanRelation(..), SpanTag(..)) 10 | 11 | import Control.Monad.Trans (liftIO, MonadIO) 12 | import Control.Monad (void) 13 | import Data.Monoid ((<>), mempty) 14 | import Data.Aeson 15 | import Data.Maybe (fromMaybe) 16 | import Data.Int (Int64) 17 | import qualified Data.Text as T 18 | import qualified Data.Text.Encoding as T 19 | import qualified Data.ByteString.Char8 as BS 20 | import qualified Data.ByteString.Lazy as LBS 21 | import qualified Data.ByteString.Lazy.Char8 as LBSC8 22 | import qualified Data.ByteString.Lex.Integral as BS 23 | import Network.HTTP.Client 24 | import Network.HTTP.Types.Header (Header) 25 | import Data.Aeson.Types (ToJSON(toJSON)) 26 | import qualified Data.Map as Map 27 | 28 | 29 | -- | Publish 'Span' in the . No call is made 30 | -- on an empty span list 31 | publishDataDog :: MonadIO m => 32 | String -- ^ The address of the backend server 33 | -> Manager 34 | -> [Header] 35 | -> [Span] -- ^ The traced spans to send to a DataDog backend 36 | -> m (Maybe (Response T.Text)) 37 | publishDataDog _ _ _ [] = pure Nothing 38 | publishDataDog destination manager additionalHeaders spans = 39 | liftIO . fmap (Just . fmap decode) $ httpLbs ddReq manager 40 | where 41 | decode = T.decodeUtf8 . LBS.toStrict 42 | req = parseRequest_ destination 43 | body = RequestBodyLBS . encode $ DataDogSpan <$> spans 44 | ddReq = req { method = "POST", 45 | requestBody = body, 46 | requestHeaders = [("content-type", "application/json")] <> additionalHeaders 47 | } 48 | 49 | newtype DataDogSpan = DataDogSpan Span 50 | instance ToJSON DataDogSpan where 51 | toJSON (DataDogSpan span) = object $ [ 52 | "trace_id" .= (unTrace . traceId $ context span), 53 | "span_id" .= (unSpan . spanId $ context span), 54 | "name" .= unOp (operationName span), 55 | "resource" .= unOp (operationName span), 56 | "start" .= (floor . toNanos $ timestamp span :: Int64), 57 | "type" .= ("web"::T.Text), 58 | "duration" .= (toNanos $ duration span), 59 | "service" .= (serviceName span), 60 | "meta" .= (unTag <$> tags span) 61 | ] <> 62 | parentId (relations span) 63 | where 64 | toNanos = (*) 1000000000 65 | unOp (OpName n) = n 66 | unSpan (SpanId sid) = sid 67 | unTrace (TraceId tid) = tid 68 | parentId (ChildOf ctx:_) = ["parent_id" .= (unSpan $ spanId ctx)] 69 | parentId (FollowsFrom ctx:_) = ["parent_id" .= (unSpan $ spanId ctx)] 70 | parentId _ = [] 71 | padLeft 0 txt = txt 72 | padLeft n txt 73 | | T.length txt < n = padLeft n ("0"<>txt) 74 | | otherwise = txt 75 | unTag (TagString a) = toJSON a 76 | unTag (TagBool a) = toJSON a 77 | unTag (TagInt a) = toJSON a 78 | unTag (TagDouble a) = toJSON a 79 | -------------------------------------------------------------------------------- /src/Tracing/Zipkin.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Tracing.Zipkin ( 4 | publishZipkin, 5 | ZipkinSpan(..) 6 | ) where 7 | 8 | import Tracing.Core (Span(..), SpanId(..), OpName(..), TraceId(..), SpanContext(..), 9 | SpanRelation(..)) 10 | 11 | import Control.Monad.Trans (liftIO, MonadIO) 12 | import Control.Monad (void) 13 | import Data.Monoid ((<>), mempty) 14 | import Data.Aeson 15 | import Data.Maybe (fromMaybe) 16 | import Data.Int (Int64) 17 | import qualified Data.Text as T 18 | import qualified Data.Text.Encoding as T 19 | import qualified Data.ByteString.Char8 as BS 20 | import qualified Data.ByteString.Lazy as LBS 21 | import qualified Data.ByteString.Lex.Integral as BS 22 | import qualified Data.HashMap.Strict as HM 23 | import Network.HTTP.Client 24 | 25 | 26 | -- | Publish 'Span' in the . No call is made 27 | -- on an empty 28 | publishZipkin :: MonadIO m => 29 | String -- ^ The address of the backend server 30 | -> Manager 31 | -> [Span] -- ^ The traced spans to send to a Zipkin backend 32 | -> m (Maybe (Response T.Text)) 33 | publishZipkin _ _ [] = pure Nothing 34 | publishZipkin destination manager spans = 35 | liftIO . fmap (Just . fmap decode) $ httpLbs zipkinReq manager 36 | where 37 | decode = T.decodeUtf8 . LBS.toStrict 38 | req = parseRequest_ destination 39 | body = RequestBodyLBS . encode $ ZipkinSpan <$> spans 40 | zipkinReq = req { method = "POST", requestBody = body, requestHeaders = [("content-type", "application/json")]} 41 | 42 | newtype ZipkinSpan = ZipkinSpan Span 43 | instance ToJSON ZipkinSpan where 44 | toJSON (ZipkinSpan span) = object $ [ 45 | "traceId" .= unTrace (traceId $ context span), 46 | "id" .= unSpan (spanId $ context span), 47 | "name" .= unOp (operationName span), 48 | "timestamp" .= (floor . toMicros $ timestamp span :: Int64), 49 | "kind" .= ("CLIENT"::T.Text), 50 | "duration" .= (toMicros $ duration span), 51 | "debug" .= (debug span), 52 | "localEndpoint" .= (object ["serviceName" .= (serviceName span)]) 53 | ] <> 54 | parentId (relations span) 55 | where 56 | toMicros = (*) 1000000 57 | unOp (OpName n) = n 58 | zipkinFormatId = padLeft 16 . T.pack . BS.unpack . fromMaybe "-1" 59 | unTrace (TraceId t) = zipkinFormatId $ BS.packHexadecimal t 60 | unSpan (SpanId s) = zipkinFormatId $ BS.packHexadecimal s 61 | parentId (ChildOf ctx:_) = ["parentId" .= (unSpan $ spanId ctx)] 62 | parentId (FollowsFrom ctx:_) = ["parentId" .= (unSpan $ spanId ctx)] 63 | parentId _ = [] 64 | padLeft 0 txt = txt 65 | padLeft n txt 66 | | T.length txt < n = padLeft n ("0"<>txt) 67 | | otherwise = txt 68 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-18.18 2 | allow-newer: true 3 | packages: 4 | - . 5 | allow-newer: true 6 | -------------------------------------------------------------------------------- /test/DataDog/ClientSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns, OverloadedStrings #-} 2 | 3 | module DataDog.ClientSpec ( 4 | ddSpec 5 | ) where 6 | 7 | import Tracing.DataDog 8 | import Tracing.Core 9 | import Instances() 10 | 11 | import Data.Maybe (fromMaybe, maybe, isJust) 12 | import Data.Aeson 13 | import Data.Aeson.Types (parseMaybe) 14 | import qualified Data.Text as T 15 | import Test.HUnit 16 | import Test.QuickCheck hiding (sample) 17 | import Test.Tasty 18 | import Test.Tasty.HUnit (testCase) 19 | import Test.Tasty.QuickCheck (testProperty) 20 | import Web.HttpApiData (parseUrlPiece) 21 | import Data.Int 22 | 23 | ddSpec :: TestTree 24 | ddSpec = testGroup "DataDog Spec" $ [ 25 | testCase "start is in nanoseconds" $ do 26 | s <- generate arbitrary 27 | let fromNanos = maybe 0 (/ 1000000000) . parseMaybe ( withObject "" (.: "start") ) $ toJSON (DataDogSpan (s :: Span)) 28 | fromNanos @=? timestamp s 29 | , testCase "parentId set when a child Relation is present" $ do 30 | s <- generate arbitrary :: IO Span 31 | c <- generate arbitrary :: IO SpanContext 32 | let s' = s {relations = [ChildOf c]} 33 | let isPresent = maybe False (> (0:: Int64)) . parseMaybe ( withObject "" (.: "parent_id") ) $ toJSON (DataDogSpan s') 34 | isPresent @=? True 35 | , testCase "parentId set when a FollowsFrom Relation is present" $ do 36 | s <- generate arbitrary :: IO Span 37 | c <- generate arbitrary :: IO SpanContext 38 | let s' = s {relations = [FollowsFrom c]} 39 | let isPresent = maybe False (> (0::Int64)) . parseMaybe ( withObject "" (.: "parent_id") ) $ toJSON (DataDogSpan s') 40 | isPresent @=? True 41 | , testCase "parentId unset when no Relation is present" $ do 42 | s <- generate arbitrary :: IO Span 43 | let s' = s {relations = []} 44 | let isPresent = maybe False (> (0::Int64)) . parseMaybe ( withObject "" (.: "parent_id") ) $ toJSON (DataDogSpan s') 45 | isPresent @=? False 46 | ] 47 | -------------------------------------------------------------------------------- /test/Instances.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns, OverloadedStrings, DuplicateRecordFields #-} 2 | 3 | module Instances where 4 | 5 | import Servant.Tracing 6 | import Tracing.Core 7 | 8 | import Data.Char (isAscii) 9 | import Test.QuickCheck hiding (sample) 10 | import Data.Time.Clock.POSIX 11 | import qualified Data.Map as M 12 | import qualified Data.Text as T 13 | 14 | instance Arbitrary TracingInstructions where 15 | arbitrary = do 16 | tid <- arbitrary 17 | sid <- arbitrary 18 | parentSpanId <- arbitrary 19 | dbg <- arbitrary 20 | sample <- arbitrary 21 | pure TracingInstructions { 22 | traceId=tid, 23 | spanId=sid, 24 | parentSpanId, 25 | debug=dbg, 26 | sample 27 | } 28 | where 29 | 30 | positiveArb :: (Integral a, Arbitrary a) => Gen a 31 | positiveArb = suchThat arbitrary (>= 0) 32 | 33 | instance Arbitrary TraceId where 34 | arbitrary = TraceId <$> positiveArb 35 | 36 | instance Arbitrary SpanId where 37 | arbitrary = SpanId <$> positiveArb 38 | 39 | instance Arbitrary SpanContext where 40 | arbitrary = SpanContext <$> arbitrary <*> arbitrary 41 | 42 | instance Arbitrary OpName where 43 | arbitrary = OpName <$> arbitrary 44 | 45 | instance Arbitrary SpanRelation where 46 | arbitrary = do 47 | rel <- elements [ChildOf, FollowsFrom] 48 | rel <$> arbitrary 49 | 50 | instance Arbitrary T.Text where 51 | arbitrary = 52 | T.pack <$> listOf (suchThat arbitrary isAscii) 53 | 54 | instance Arbitrary SpanRelationTag where 55 | arbitrary = elements [Child, Follows] 56 | 57 | -- TODO add tags and baggage once they're supported 58 | instance Arbitrary Span where 59 | arbitrary = do 60 | o <- arbitrary 61 | c <- arbitrary 62 | rels <- arbitrary 63 | dbg <- arbitrary 64 | svc <- arbitrary 65 | pure Span { 66 | operationName = o, 67 | context = c, 68 | timestamp = 1522024571, 69 | duration = 123, 70 | relations = rels, 71 | tags = M.empty, 72 | baggage = M.empty, 73 | debug = dbg, 74 | serviceName = svc 75 | } 76 | 77 | -------------------------------------------------------------------------------- /test/Servant/TracingSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns, OverloadedStrings #-} 2 | 3 | module Servant.TracingSpec ( 4 | tracingProps, 5 | tracingSpecs 6 | ) where 7 | 8 | import Servant.Tracing (TracingInstructions(..), instructionsToHeader) 9 | import Tracing.Core (TraceId(..), SpanId(..)) 10 | import Instances () 11 | 12 | import Data.Maybe (fromMaybe, maybe) 13 | import qualified Data.Text as T 14 | import qualified Data.Text.Read as T 15 | import Test.HUnit 16 | import Test.QuickCheck hiding (sample) 17 | import Test.Tasty 18 | import Test.Tasty.HUnit (testCase) 19 | import Test.Tasty.QuickCheck (testProperty) 20 | import Web.HttpApiData (parseUrlPiece) 21 | 22 | tracingProps :: TestTree 23 | tracingProps = testGroup "Servant Properties" [ 24 | instructionProps 25 | ] 26 | 27 | tracingSpecs :: TestTree 28 | tracingSpecs = testGroup "Servant Specification" [ 29 | testCase "Sample field controls low bit" $ let 30 | header = instructionsToHeader $ dummyInst1 {debug = False} 31 | fields = extractFields header 32 | in fields @=? 1, 33 | testCase "Both fields set == 3" $ let 34 | header = instructionsToHeader dummyInst1 35 | fields = extractFields header 36 | in fields @=? 3, 37 | testCase "TraceId converts to hex representation" $ let 38 | header = instructionsToHeader $ dummyInst1 {traceId = TraceId 15} 39 | traceId = extractId . head $ T.splitOn ":" header 40 | in traceId @=? 0xF, 41 | testCase "SpanId converts to hex representation" $ let 42 | header = instructionsToHeader $ dummyInst1 {spanId = SpanId 255} 43 | traceId = extractId . head . tail $ T.splitOn ":" header 44 | in traceId @=? 0xFF, 45 | testCase "4:3:4:3 == TracingInstructions 4 3 4 True True" $ let 46 | inst = parseUrlPiece "4:3:4:3" 47 | in case inst of 48 | Right inst -> inst @=? (TracingInstructions (TraceId 4) (SpanId 3) (Just $ SpanId 4) True True) 49 | Left _ -> assertFailure $ "Failed: "++ show inst, 50 | testCase "4:3::3 == TracingInstructions 4 3 Nothing True True" $ let 51 | inst = parseUrlPiece "4:3::3" 52 | in case inst of 53 | Right inst -> inst @=? (TracingInstructions (TraceId 4) (SpanId 3) Nothing True True) 54 | Left _ -> assertFailure $ "Failed: "++ show inst 55 | ] 56 | where 57 | dummyInst1 = TracingInstructions (TraceId 1) (SpanId 1) Nothing True True 58 | extractId = maybe (-1) fst . toMaybe . T.hexadecimal 59 | extractFields = maybe (-1) fst . toMaybe . T.hexadecimal . last . T.splitOn ":" 60 | toMaybe (Left _) = Nothing 61 | toMaybe (Right a) = Just a 62 | 63 | instructionProps :: TestTree 64 | instructionProps = testGroup "TracingInstructions" [ 65 | testProperty "parseUrlPiece . toHeader == pure" $ 66 | \ti -> pure ti == (parseUrlPiece $ instructionsToHeader ti) 67 | ] 68 | 69 | 70 | 71 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | 2 | import Servant.TracingSpec (tracingProps, tracingSpecs) 3 | import Zipkin.ClientSpec (zipkinProps, zipkinSpec) 4 | import DataDog.ClientSpec (ddSpec) 5 | import Tracing.CoreSpec (coreSpec, coreProps) 6 | import Test.Tasty 7 | 8 | main :: IO () 9 | main = defaultMain $ testGroup "Tracing" [ 10 | tracingProps, 11 | tracingSpecs, 12 | zipkinProps, 13 | zipkinSpec, 14 | ddSpec, 15 | coreSpec 16 | ] 17 | -------------------------------------------------------------------------------- /test/Tracing/CoreSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns, OverloadedStrings, UndecidableInstances, DuplicateRecordFields, FlexibleInstances, MultiParamTypeClasses #-} 2 | 3 | module Tracing.CoreSpec ( 4 | coreProps, 5 | coreSpec 6 | ) where 7 | 8 | import Tracing.Core 9 | import Instances() 10 | 11 | import Control.Monad.Trans (liftIO, MonadIO) 12 | import Control.Monad.Trans.Control (MonadBaseControl) 13 | import Control.Monad.Reader 14 | import Data.Maybe (fromMaybe, maybe, isJust) 15 | import Data.Aeson 16 | import Data.Aeson.Types (parseMaybe) 17 | import Data.IORef (IORef, newIORef, readIORef) 18 | import qualified Data.Text as T 19 | import Test.HUnit 20 | import Test.QuickCheck hiding (sample) 21 | import Test.Tasty 22 | import Test.Tasty.HUnit (testCase) 23 | import Test.Tasty.QuickCheck (testProperty) 24 | import Web.HttpApiData (parseUrlPiece) 25 | 26 | coreProps :: TestTree 27 | coreProps = testGroup "Tracing Core Properties" $ [ 28 | ] 29 | 30 | coreSpec :: TestTree 31 | coreSpec = testGroup "Tracing Core Specification" $ [ 32 | testCase "logged span id == fresh id for top level span" $ do 33 | ctx <- newContext 34 | flip runReaderT ctx . recordSpan Nothing [] "Top Level Test" $ pure (7 + 8) 35 | traces <- readIORef . spanBuffer $ tracer ctx 36 | let h = head traces 37 | length traces @=? 1 38 | relations h @=? [] 39 | (sid $ context h) @=? SpanId 1234 40 | , testCase "logged span id == new id for child span" $ do 41 | ctx <- newContext 42 | flip runReaderT ctx . recordSpan (Just Child) [] "Child Test" $ pure (7 + 8) 43 | traces <- readIORef . spanBuffer $ tracer ctx 44 | let h = head traces 45 | length traces @=? 1 46 | (length $ relations h) @=? 1 47 | ((sid $ context h) /= SpanId 1234) @? "Parent Id is still the child span's Id" 48 | , testCase "logged span id == new id for successor span" $ do 49 | ctx <- newContext 50 | flip runReaderT ctx . recordSpan (Just Follows) [] "Successor Test" $ pure (7 + 8) 51 | traces <- readIORef . spanBuffer $ tracer ctx 52 | let h = head traces 53 | length traces @=? 1 54 | ((sid $ context h) /= SpanId 1234) @? "Parent Id is still the successor span's Id" 55 | , testCase "child span sets parent relation" $ do 56 | ctx <- newContext 57 | flip runReaderT ctx . recordSpan (Just Child) [] "Foo" $ pure (7 + 8) 58 | traces <- readIORef . spanBuffer $ tracer ctx 59 | let h = head traces 60 | length traces @=? 1 61 | ((\(ChildOf s) -> sid s ) . head $ relations h) @=? SpanId 1234 62 | , testCase "successor span sets precursor relation" $ do 63 | ctx <- newContext 64 | flip runReaderT ctx . recordSpan (Just Follows) [] "Foo" $ pure (7 + 8) 65 | traces <- readIORef . spanBuffer $ tracer ctx 66 | let h = head traces 67 | ((\(FollowsFrom s) -> sid s ) . head $ relations h) @=? SpanId 1234 68 | , testCase "sibling spans share same parent" $ do 69 | ctx <- newContext 70 | flip runReaderT ctx . recordSpan (Just Child) [] "Foo" $ pure (7 + 8) 71 | flip runReaderT ctx . recordSpan (Just Child) [] "Foo" $ pure (7 + 8) 72 | [x,y] <- readIORef . spanBuffer $ tracer ctx 73 | (parentId x == parentId y) @? "Sibling spans must share a parent" 74 | , testCase "sibling successor spans share same parent" $ do 75 | ctx <- newContext 76 | flip runReaderT ctx . recordSpan (Just Follows) [] "Foo" $ pure (7 + 8) 77 | flip runReaderT ctx . recordSpan (Just Follows) [] "Foo" $ pure (7 + 8) 78 | [x,y] <- readIORef . spanBuffer $ tracer ctx 79 | (parentId x == parentId y) @? "Sibling spans must share a parent" 80 | , testCase "sibling heterogeneous spans share same parent" $ do 81 | ctx <- newContext 82 | flip runReaderT ctx . recordSpan (Just Follows) [] "Foo" $ pure (7 + 8) 83 | flip runReaderT ctx . recordSpan (Just Child) [] "Foo" $ pure (7 + 8) 84 | [x,y] <- readIORef . spanBuffer $ tracer ctx 85 | (parentId x == parentId y) @? "Sibling spans must share a parent" 86 | , testCase "sibling spans have distinct ids" $ do 87 | ctx <- newContext 88 | flip runReaderT ctx . recordSpan (Just Follows) [] "Foo" $ pure (7 + 8) 89 | flip runReaderT ctx . recordSpan (Just Child) [] "Foo" $ pure (7 + 8) 90 | [x,y] <- readIORef . spanBuffer $ tracer ctx 91 | ((sid $ context x) /= (sid $ context y)) @? "Sibling spans must have different ids" 92 | {- , testCase "nested calls chain" $ do 93 | ctx <- newContext 94 | flip runReaderT ctx . recordSpan Nothing [] "Foo" $ 95 | recordSpan (Just Child) [] "Bar" $ 96 | recordSpan (Just Child) [] "Baz" $ pure (7 + 8) 97 | -- This test will break if 'recordSpan' changes significantly 98 | [x, y, z] <- readIORef . spanBuffer $ tracer ctx 99 | let pid = x 100 | ((sid $ context x) /= (sid $ context y)) @? "Sibling spans must have different ids" 101 | -} 102 | ] 103 | 104 | newContext :: IO Ctx 105 | newContext = do 106 | cell <- newIORef [] 107 | let currSpan = SpanId 1234 108 | pure Ctx { 109 | tracer = Tracer cell "UNIT TESTING", 110 | currSpan = currSpan, 111 | dbg = True, 112 | currTrace = TraceId 9876 113 | } 114 | 115 | sid :: SpanContext -> SpanId 116 | sid SpanContext {spanId} = spanId 117 | 118 | parentId :: Span -> Maybe SpanId 119 | parentId Span {relations=((ChildOf c):_)} = Just $ sid c 120 | parentId Span {relations=((FollowsFrom c):_)} = Just $ sid c 121 | parentId _ = Nothing 122 | 123 | data Ctx = Ctx { 124 | tracer :: Tracer, 125 | currSpan :: SpanId, 126 | dbg :: Bool, 127 | currTrace :: TraceId 128 | } 129 | 130 | instance HasSpanId Ctx where 131 | getSpanId = currSpan 132 | setSpanId c s = c {currSpan = s} 133 | 134 | instance (Monad m, MonadBaseControl IO m, MonadIO m, MonadReader Ctx m) => MonadTracer m Ctx where 135 | getTracer = tracer <$> ask 136 | currentTrace = currTrace <$> ask 137 | isDebug = dbg <$> ask 138 | -------------------------------------------------------------------------------- /test/Zipkin/ClientSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns, OverloadedStrings #-} 2 | 3 | module Zipkin.ClientSpec ( 4 | zipkinProps, 5 | zipkinSpec 6 | ) where 7 | 8 | import Tracing.Zipkin 9 | import Tracing.Core 10 | import Instances() 11 | 12 | import Data.Maybe (fromMaybe, maybe, isJust) 13 | import Data.Aeson 14 | import Data.Aeson.Types (parseMaybe) 15 | import qualified Data.Text as T 16 | import Test.HUnit 17 | import Test.QuickCheck hiding (sample) 18 | import Test.Tasty 19 | import Test.Tasty.HUnit (testCase) 20 | import Test.Tasty.QuickCheck (testProperty) 21 | import Web.HttpApiData (parseUrlPiece) 22 | 23 | zipkinProps :: TestTree 24 | zipkinProps = testGroup "ZipkinProps" $ [ 25 | testProperty "traceId always at least 16 chars long" $ 26 | \s -> maybe False ((<=) 16 . T.length) . parseMaybe ( withObject "" ( .: "traceId") ) $ toJSON (ZipkinSpan (s :: Span)) 27 | , testProperty "traceId never longer than 32 chars" $ 28 | \s -> maybe False ((>=) 32 . T.length) . parseMaybe ( withObject "" ( .: "traceId") ) $ toJSON (ZipkinSpan (s :: Span)) 29 | , testProperty "spanId always 16 chars long" $ 30 | \s -> maybe False ((==) 16 . T.length) . parseMaybe ( withObject "" (.: "id") ) $ toJSON (ZipkinSpan (s :: Span)) 31 | ] 32 | 33 | 34 | zipkinSpec :: TestTree 35 | zipkinSpec = testGroup "Zipkin Spec" $ [ 36 | testCase "timestamp is in microseconds" $ do 37 | s <- generate arbitrary 38 | let fromMicros = maybe 0 (/ 1000000) . parseMaybe ( withObject "" (.: "timestamp") ) $ toJSON (ZipkinSpan (s :: Span)) 39 | fromMicros @=? timestamp s 40 | , testCase "parentId set when a child Relation is present" $ do 41 | s <- generate arbitrary :: IO Span 42 | c <- generate arbitrary :: IO SpanContext 43 | let s' = s {relations = [ChildOf c]} 44 | let isPresent = maybe False (not . T.null) . parseMaybe ( withObject "" (.: "parentId") ) $ toJSON (ZipkinSpan s') 45 | isPresent @=? True 46 | , testCase "parentId set when a FollowsFrom Relation is present" $ do 47 | s <- generate arbitrary :: IO Span 48 | c <- generate arbitrary :: IO SpanContext 49 | let s' = s {relations = [FollowsFrom c]} 50 | let isPresent = maybe False (not . T.null) . parseMaybe ( withObject "" (.: "parentId") ) $ toJSON (ZipkinSpan s') 51 | isPresent @=? True 52 | , testCase "parentId unset when no Relation is present" $ do 53 | s <- generate arbitrary :: IO Span 54 | let s' = s {relations = []} 55 | let isPresent = maybe False (not . T.null) . parseMaybe ( withObject "" (.: "parentId") ) $ toJSON (ZipkinSpan s') 56 | isPresent @=? False 57 | ] 58 | 59 | --------------------------------------------------------------------------------