servant-tracing (empty) → 0.1.0.0
raw patch · 14 files changed
+1006/−0 lines, 14 filesdep +HUnitdep +QuickCheckdep +aesonsetup-changed
Dependencies added: HUnit, QuickCheck, aeson, async, base, bytestring, bytestring-lexing, containers, hashable, http-api-data, http-client, lifted-base, monad-control, mtl, random, servant, servant-server, servant-tracing, tasty, tasty-hunit, tasty-quickcheck, text, time, transformers, unordered-containers, wai, warp
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +31/−0
- Setup.hs +2/−0
- app/Main.hs +115/−0
- servant-tracing.cabal +109/−0
- src/Servant/Tracing.hs +92/−0
- src/Tracing/Core.hs +209/−0
- src/Tracing/Zipkin.hs +68/−0
- test/Instances.hs +76/−0
- test/Servant/TracingSpec.hs +65/−0
- test/Spec.hs +14/−0
- test/Tracing/CoreSpec.hs +134/−0
- test/Zipkin/ClientSpec.hs +58/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for servant-tracing++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2018++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,31 @@+# servant-tracing++[](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/blob/master/specification.md) but is not complete. See the documentation on Hackage for module-level details.+++### Using the library++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.++```+foo :: (MonadIO m, MonadTracer m) =>+ Int+ -> m String+foo str = recordSpan+ Nothing+ [Tag "Ultimate Answer to Life, The Universe and Everything", Tag 42]+ "Compute Ultimate Question"+ $ pure "Oops"+```++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.+++#### Pending Features+- Concurrent tracing support.+- Context+- Thrift support+- Additional clients+- Pluggable samplers
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,115 @@+{-# 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
+ servant-tracing.cabal view
@@ -0,0 +1,109 @@+name: servant-tracing+version: 0.1.0.0+description: Please see the README on Github at <https://github.com/ChrisCoffey/servant-tracing#readme>+homepage: https://github.com/ChrisCoffey/servant-tracing#readme+bug-reports: https://github.com/ChrisCoffey/servant-tracing/issues+author: Chris Coffey+maintainer: chris@foldl.io+copyright: 2018 Chris Coffey+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10++extra-source-files:+ ChangeLog.md+ README.md++source-repository head+ type: git+ location: https://github.com/ChrisCoffey/servant-tracing++library+ default-extensions: DataKinds FlexibleContexts ScopedTypeVariables OverloadedStrings ViewPatterns NamedFieldPuns+ KindSignatures RecordWildCards ConstraintKinds TypeSynonymInstances FlexibleInstances+ DuplicateRecordFields GeneralizedNewtypeDeriving InstanceSigs TypeFamilies+ hs-source-dirs:+ src+ build-depends:+ base >=4.7 && <5+ , servant+ , servant-server+ , containers+ , unordered-containers+ , time+ , wai+ , bytestring+ , bytestring-lexing+ , hashable+ , mtl+ , random+ , text+ , async+ , monad-control+ , lifted-base+ , http-api-data+ , aeson+ , http-client+ exposed-modules:+ Tracing.Core+ , Tracing.Zipkin+ , Servant.Tracing+ -- 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+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , servant-tracing+ , http-api-data+ , transformers+ , containers+ , monad-control+ , text+ , mtl+ , QuickCheck+ , HUnit+ , tasty+ , tasty-quickcheck+ , tasty-hunit+ , aeson+ , containers+ , time+ other-modules:+ Servant.TracingSpec,+ Instances,+ Zipkin.ClientSpec,+ Tracing.CoreSpec+ default-language: Haskell2010
+ src/Servant/Tracing.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE RankNTypes #-}+module Servant.Tracing (+ ServantTracingT,+ WithTracing,+ TracingInstructions(..),+ instructionsToHeader,+ getInstructions+ ) where++import Tracing.Core (Tracer, TraceId(..), SpanId(..), MonadTracer, TracingInstructions(..))++import Control.Monad.Trans (liftIO, MonadIO)+import qualified Data.Text as T+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lex.Integral as BS+import Data.Text.Read(hexadecimal)+import Data.Bits (testBit, (.|.))+import Data.Maybe (catMaybes, fromMaybe)+import Data.Monoid ((<>))+import Servant+import Servant.Server+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+++-- | Jaeger format: http://jaeger.readthedocs.io/en/latest/client_libraries/#propagation-format+-- This allows the trace backend to reassemble downstream traces.+instructionsToHeader :: TracingInstructions -> T.Text+instructionsToHeader TracingInstructions {traceId=(TraceId tid), spanId=SpanId sid, parentSpanId=SpanId pid, sample, debug} =+ toField tid<>":"<> toField sid <> ":"<> toField pid <> ":" <> (T.pack $ show setFlags)+ where+ toField = T.pack . BS.unpack . fromMaybe "0" . BS.packHexadecimal+ setFlags :: Int+ setFlags = (if debug then 2 else 0) .|. (if sample then 1 else 0) .|. 0+++instance FromHttpApiData TracingInstructions where+ parseUrlPiece ::+ T.Text+ -> Either T.Text TracingInstructions+ parseUrlPiece raw =+ case T.splitOn ":" raw of+ [rawTraceId, rawSpanId, rawParentId, flags] -> let+ res = do+ traceId <- TraceId . fromIntegral . fst <$> hexadecimal rawTraceId+ spanId <- SpanId . fromIntegral . fst <$> hexadecimal rawSpanId+ parentId <- SpanId . fromIntegral . fst <$> if T.null rawParentId then pure (0 :: Integer, "") else hexadecimal rawParentId+ flagField <- fromIntegral . fst <$> hexadecimal flags+ let [sample, debug]= [sampleFlag, debugFlag] <*> [flagField]+ pure TracingInstructions {+ traceId = traceId,+ spanId = spanId,+ parentSpanId = parentId,+ sample = sample,+ debug = debug+ }+ in case res of+ Left err -> Left $ T.pack err+ Right val -> Right val+ _ -> Left $ raw <> " is not a valid uber-trace-id header"+ where+ sampleFlag :: Int -> Bool+ sampleFlag = (`testBit` 0)+ debugFlag :: Int -> Bool+ debugFlag = (`testBit` 1)+++-- 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++-- | In the event that there are no 'TracingInstructions' for this call, generate new instructions.+--+-- This has a+getInstructions :: MonadIO m =>+ Bool+ -> Maybe TracingInstructions+ -> m TracingInstructions+getInstructions debug Nothing = do+ newTraceId <- liftIO $ randomRIO (0, maxBound)+ newSpanId <- liftIO $ randomRIO (0, maxBound)+ sample <- liftIO $ randomRIO (0, 1000)+ pure TracingInstructions {+ traceId = TraceId newTraceId,+ spanId = SpanId newSpanId,+ parentSpanId = SpanId 0,+ debug,+ sample = sample == (1::Int)+ }+getInstructions _ (Just inst) = pure inst
+ src/Tracing/Core.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE ExistentialQuantification, RankNTypes, UndecidableInstances #-}++module Tracing.Core (+ Span(..),+ SpanRelation(..),+ SpanRelationTag(..),+ SpanContext(..),+ SpanTag(..),+ OpName(..),+ SpanId(..),+ TraceId(..),+ Tracer(..),+ TracingInstructions(..),+ MonadTracer(..),+ ToSpanTag(..),++ 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)++-- | Human-readable name for the span+newtype OpName = OpName Text+ deriving (Eq, Ord, Show, IsString)++-- | An opaque & unique identifier for a trace segment, called a Span+newtype SpanId = SpanId Int64+ deriving (Eq, Ord, Show, FromHttpApiData)++-- | An opaque & unique identifier for a logical operation. Traces are composed of many 'Span's+newtype TraceId = TraceId Int64+ deriving (Eq, Ord, Show, FromHttpApiData)++-- | 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+ 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++-- | 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) =>+ 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++ -- generates a thunk that completes once the action provided to 'recordSpan' finishes.+ -- While this is running, there is a new "activeSpanId" that any children will use. Nested calls+ -- generate a stack of spans.+ 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, -- TODO Allow adding these+ 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+ -- When this is a top level span, there should be no SpanRelationTag. These two functions work+ -- together to ensure the spans nest properly+ 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 -> []++-- | Instructions that are specific to a single trace+data TracingInstructions =+ TracingInstructions {+ traceId :: !TraceId,+ spanId :: !SpanId,+ parentSpanId :: !SpanId,+ debug :: !Bool,+ sample :: !Bool+ } deriving (Eq, Show)++newtype ActiveSpan =+ ActiveSpan {finishSpan :: UTCTime -> Span}++-- | Global context required for tracing. The 'spanBuffer' should be manually drained by library users.+data Tracer =+ Tracer {+ spanBuffer :: IORef [Span],+ svcName :: T.Text+ }++-- | Uniquely identifies a given 'Span' & points to its encompasing trace+data SpanContext =+ SpanContext {+ traceId :: !TraceId,+ spanId :: !SpanId+ } deriving (Eq, Show)++-- | Spans may be top level, a child, or logically follow from a given span.+data SpanRelation =+ ChildOf !SpanContext | FollowsFrom !SpanContext+ deriving (Eq, Show)++-- | Indicates the type of relation this span represents+data SpanRelationTag = Child | Follows++-- | A timed section of code with a logical name and 'SpanContext'. Individual spans will be reconstructed by an+-- OpenTracing backend into a single trace.+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++-- | Dump the details of a span. Used for debugging or logging+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++-- | Used to embed additional information into a Span for consumption & viewing in a tracing backend+data SpanTag+ = TagString !Text+ | TagBool !Bool+ | TagInt !Int64+ | TagDouble !Double+ deriving (Eq, Show)++-- | Allows for easily representing multiple types in a tag list+data Tag = forall a. ToSpanTag a => Tag T.Text a++-- | The type in question may be converted into a 'SpanTag'+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
+ src/Tracing/Zipkin.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Tracing.Zipkin (+ publishZipkin,+ ZipkinSpan(..)+ ) where++import Tracing.Core (Span(..), SpanId(..), OpName(..), TraceId(..), SpanContext(..),+ SpanRelation(..))++import Control.Monad.Trans (liftIO, MonadIO)+import Control.Monad (void)+import Data.Monoid ((<>), mempty)+import Data.Aeson+import Data.Maybe (fromMaybe)+import Data.Int (Int64)+import qualified Data.Text as T+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.Lex.Integral as BS+import qualified Data.HashMap.Strict as HM+import Network.HTTP.Client+++-- | Publish 'Span' in the Zipkin format (TODO add link to zipkin spec here). No call is made+-- on an empty+publishZipkin :: MonadIO m =>+ String -- The address of the backend server+ -> Manager+ -> [Span] -- ^ The traced spans to send to a Zipkin backend+ -> m (Maybe (Response T.Text))+publishZipkin _ _ [] = pure Nothing+publishZipkin destination manager spans =+ liftIO . fmap (Just . fmap decode) $ httpLbs zipkinReq manager+ where+ decode = T.decodeUtf8 . LBS.toStrict+ req = parseRequest_ destination+ body = RequestBodyLBS . encode $ ZipkinSpan <$> spans+ zipkinReq = req { method = "POST", requestBody = body, requestHeaders = [("content-type", "application/json")]}++newtype ZipkinSpan = ZipkinSpan Span+instance ToJSON ZipkinSpan where+ toJSON (ZipkinSpan span) = object $ [+ "traceId" .= unTrace (traceId $ context span),+ "id" .= unSpan (spanId $ context span),+ "name" .= unOp (operationName span),+ "timestamp" .= (floor . toMicros $ timestamp span :: Int64),+ "kind" .= ("CLIENT"::T.Text),+ "duration" .= (toMicros $ duration span),+ "debug" .= (debug span),+ "localEndpoint" .= (object ["serviceName" .= (serviceName span)])+ ] <>+ parentId (relations span)+ where+ toMicros = (*) 1000000+ unOp (OpName n) = n+ 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 _ = []+ padLeft 0 txt = txt+ padLeft n txt+ | T.length txt < n = padLeft n ("0"<>txt)+ | otherwise = txt
+ test/Instances.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE NamedFieldPuns, OverloadedStrings, DuplicateRecordFields #-}++module Instances where++import Servant.Tracing+import Tracing.Core++import Data.Char (isAscii)+import Test.QuickCheck hiding (sample)+import Data.Time.Clock.POSIX+import qualified Data.Map as M+import qualified Data.Text as T++instance Arbitrary TracingInstructions where+ arbitrary = do+ tid <- arbitrary+ sid <- arbitrary+ parentSpanId <- arbitrary+ dbg <- arbitrary+ sample <- arbitrary+ pure TracingInstructions {+ traceId=tid,+ spanId=sid,+ parentSpanId,+ debug=dbg,+ sample+ }+ where++positiveArb :: (Integral a, Arbitrary a) => Gen a+positiveArb = suchThat arbitrary (>= 0)++instance Arbitrary TraceId where+ arbitrary = TraceId <$> positiveArb++instance Arbitrary SpanId where+ arbitrary = SpanId <$> positiveArb++instance Arbitrary SpanContext where+ arbitrary = SpanContext <$> arbitrary <*> arbitrary++instance Arbitrary OpName where+ arbitrary = OpName <$> arbitrary++instance Arbitrary SpanRelation where+ arbitrary = do+ rel <- elements [ChildOf, FollowsFrom]+ rel <$> arbitrary++instance Arbitrary T.Text where+ arbitrary =+ T.pack <$> listOf (suchThat arbitrary isAscii)++instance Arbitrary SpanRelationTag where+ arbitrary = elements [Child, Follows]++-- TODO add tags and baggage once they're supported+instance Arbitrary Span where+ arbitrary = do+ o <- arbitrary+ c <- arbitrary+ rels <- arbitrary+ dbg <- arbitrary+ svc <- arbitrary+ pure Span {+ operationName = o,+ context = c,+ timestamp = 1522024571,+ duration = 123,+ relations = rels,+ tags = M.empty,+ baggage = M.empty,+ debug = dbg,+ serviceName = svc+ }+
+ test/Servant/TracingSpec.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE NamedFieldPuns, OverloadedStrings #-}++module Servant.TracingSpec (+ tracingProps,+ tracingSpecs+ ) where++import Servant.Tracing (TracingInstructions(..), instructionsToHeader)+import Tracing.Core (TraceId(..), SpanId(..))+import Instances ()++import Data.Maybe (fromMaybe, maybe)+import qualified Data.Text as T+import qualified Data.Text.Read as T+import Test.HUnit+import Test.QuickCheck hiding (sample)+import Test.Tasty+import Test.Tasty.HUnit (testCase)+import Test.Tasty.QuickCheck (testProperty)+import Web.HttpApiData (parseUrlPiece)++tracingProps :: TestTree+tracingProps = testGroup "Servant Properties" [+ instructionProps+ ]++tracingSpecs :: TestTree+tracingSpecs = testGroup "Servant Specification" [+ testCase "Sample field controls low bit" $ let+ header = instructionsToHeader $ dummyInst1 {debug = False}+ fields = extractFields header+ in fields @=? 1,+ testCase "Both fields set == 3" $ let+ header = instructionsToHeader dummyInst1+ fields = extractFields header+ in fields @=? 3,+ testCase "TraceId converts to hex representation" $ let+ header = instructionsToHeader $ dummyInst1 {traceId = TraceId 15}+ traceId = extractId . head $ T.splitOn ":" header+ in traceId @=? 0xF,+ testCase "SpanId converts to hex representation" $ let+ header = instructionsToHeader $ dummyInst1 {spanId = SpanId 255}+ traceId = extractId . head . tail $ T.splitOn ":" header+ in traceId @=? 0xFF,+ testCase "4:3:4:3 == TracingInstructions 4 3 4 True True" $ let+ inst = parseUrlPiece "4:3:4:3"+ in case inst of+ Right inst -> inst @=? (TracingInstructions (TraceId 4) (SpanId 3) (SpanId 4) True True)+ Left _ -> assertFailure $ "Failed: "++ show inst+ ]+ where+ dummyInst1 = TracingInstructions (TraceId 1) (SpanId 1) (SpanId 0) True True+ extractId = maybe (-1) fst . toMaybe . T.hexadecimal+ extractFields = maybe (-1) fst . toMaybe . T.hexadecimal . last . T.splitOn ":"+ toMaybe (Left _) = Nothing+ toMaybe (Right a) = Just a++instructionProps :: TestTree+instructionProps = testGroup "TracingInstructions" [+ testProperty "parseUrlPiece . toHeader == pure" $+ \ti -> pure ti == (parseUrlPiece $ instructionsToHeader ti)+ ]+++
+ test/Spec.hs view
@@ -0,0 +1,14 @@++import Servant.TracingSpec (tracingProps, tracingSpecs)+import Zipkin.ClientSpec (zipkinProps, zipkinSpec)+import Tracing.CoreSpec (coreSpec, coreProps)+import Test.Tasty++main :: IO ()+main = defaultMain $ testGroup "Tracing" [+ tracingProps,+ tracingSpecs,+ zipkinProps,+ zipkinSpec,+ coreSpec+ ]
+ test/Tracing/CoreSpec.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE NamedFieldPuns, OverloadedStrings, UndecidableInstances, DuplicateRecordFields, FlexibleInstances #-}++module Tracing.CoreSpec (+ coreProps,+ coreSpec+ ) where++import Tracing.Core+import Instances()++import Control.Monad.Trans (liftIO, MonadIO)+import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.Reader+import Data.Maybe (fromMaybe, maybe, isJust)+import Data.Aeson+import Data.Aeson.Types (parseMaybe)+import Data.IORef (IORef, newIORef, readIORef)+import qualified Data.Text as T+import Test.HUnit+import Test.QuickCheck hiding (sample)+import Test.Tasty+import Test.Tasty.HUnit (testCase)+import Test.Tasty.QuickCheck (testProperty)+import Web.HttpApiData (parseUrlPiece)++coreProps :: TestTree+coreProps = testGroup "Tracing Core Properties" $ [+ ]++coreSpec :: TestTree+coreSpec = testGroup "Tracing Core Specification" $ [+ testCase "logged span id == fresh id for top level span" $ do+ ctx <- newContext+ flip runReaderT ctx . recordSpan Nothing [] "Top Level Test" $ pure (7 + 8)+ traces <- readIORef . spanBuffer $ tracer ctx+ let h = head traces+ length traces @=? 1+ relations h @=? []+ (sid $ context h) @=? SpanId 1234+ , testCase "logged span id == new id for child span" $ do+ ctx <- newContext+ flip runReaderT ctx . recordSpan (Just Child) [] "Child Test" $ pure (7 + 8)+ traces <- readIORef . spanBuffer $ tracer ctx+ let h = head traces+ length traces @=? 1+ (length $ relations h) @=? 1+ ((sid $ context h) /= SpanId 1234) @? "Parent Id is still the child span's Id"+ , testCase "logged span id == new id for successor span" $ do+ ctx <- newContext+ flip runReaderT ctx . recordSpan (Just Follows) [] "Successor Test" $ pure (7 + 8)+ traces <- readIORef . spanBuffer $ tracer ctx+ let h = head traces+ length traces @=? 1+ ((sid $ context h) /= SpanId 1234) @? "Parent Id is still the successor span's Id"+ , testCase "child span sets parent relation" $ do+ ctx <- newContext+ flip runReaderT ctx . recordSpan (Just Child) [] "Foo" $ pure (7 + 8)+ traces <- readIORef . spanBuffer $ tracer ctx+ let h = head traces+ length traces @=? 1+ ((\(ChildOf s) -> sid s ) . head $ relations h) @=? SpanId 1234+ , testCase "successor span sets precursor relation" $ do+ ctx <- newContext+ flip runReaderT ctx . recordSpan (Just Follows) [] "Foo" $ pure (7 + 8)+ traces <- readIORef . spanBuffer $ tracer ctx+ let h = head traces+ ((\(FollowsFrom s) -> sid s ) . head $ relations h) @=? SpanId 1234+ , testCase "sibling spans share same parent" $ do+ ctx <- newContext+ flip runReaderT ctx . recordSpan (Just Child) [] "Foo" $ pure (7 + 8)+ flip runReaderT ctx . recordSpan (Just Child) [] "Foo" $ pure (7 + 8)+ [x,y] <- readIORef . spanBuffer $ tracer ctx+ (parentId x == parentId y) @? "Sibling spans must share a parent"+ , testCase "sibling successor spans share same parent" $ do+ ctx <- newContext+ flip runReaderT ctx . recordSpan (Just Follows) [] "Foo" $ pure (7 + 8)+ flip runReaderT ctx . recordSpan (Just Follows) [] "Foo" $ pure (7 + 8)+ [x,y] <- readIORef . spanBuffer $ tracer ctx+ (parentId x == parentId y) @? "Sibling spans must share a parent"+ , testCase "sibling heterogeneous spans share same parent" $ do+ ctx <- newContext+ flip runReaderT ctx . recordSpan (Just Follows) [] "Foo" $ pure (7 + 8)+ flip runReaderT ctx . recordSpan (Just Child) [] "Foo" $ pure (7 + 8)+ [x,y] <- readIORef . spanBuffer $ tracer ctx+ (parentId x == parentId y) @? "Sibling spans must share a parent"+ , testCase "sibling spans have distinct ids" $ do+ ctx <- newContext+ flip runReaderT ctx . recordSpan (Just Follows) [] "Foo" $ pure (7 + 8)+ flip runReaderT ctx . recordSpan (Just Child) [] "Foo" $ pure (7 + 8)+ [x,y] <- readIORef . spanBuffer $ tracer ctx+ ((sid $ context x) /= (sid $ context y)) @? "Sibling spans must have different ids"+ {- , testCase "nested calls chain" $ do+ ctx <- newContext+ flip runReaderT ctx . recordSpan Nothing [] "Foo" $+ recordSpan (Just Child) [] "Bar" $+ recordSpan (Just Child) [] "Baz"+ -- This test will break if 'recordSpan' changes significantly+ [x, y, z] <- readIORef . spanBuffer $ tracer ctx+ let pid =+ ((sid $ context x) /= (sid $ context y)) @? "Sibling spans must have different ids"+ -}+ ]++newContext :: IO Ctx+newContext = do+ cell <- newIORef []+ currSpan <- newIORef $ SpanId 1234+ pure Ctx {+ tracer = Tracer cell "UNIT TESTING",+ currSpan = currSpan,+ dbg = True,+ currTrace = TraceId 9876+ }++sid :: SpanContext -> SpanId+sid SpanContext {spanId} = spanId++parentId :: Span -> Maybe SpanId+parentId Span {relations=((ChildOf c):_)} = Just $ sid c+parentId Span {relations=((FollowsFrom c):_)} = Just $ sid c+parentId _ = Nothing++data Ctx = Ctx {+ tracer :: Tracer,+ currSpan :: IORef SpanId,+ dbg :: Bool,+ currTrace :: TraceId+ }++instance (Monad m, MonadBaseControl IO m, MonadIO m, MonadReader Ctx m) => MonadTracer m where+ getTracer = tracer <$> ask+ currentTrace = currTrace <$> ask+ currentSpan = currSpan <$> ask+ isDebug = dbg <$> ask
+ test/Zipkin/ClientSpec.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE NamedFieldPuns, OverloadedStrings #-}++module Zipkin.ClientSpec (+ zipkinProps,+ zipkinSpec+ ) where++import Tracing.Zipkin+import Tracing.Core+import Instances()++import Data.Maybe (fromMaybe, maybe, isJust)+import Data.Aeson+import Data.Aeson.Types (parseMaybe)+import qualified Data.Text as T+import Test.HUnit+import Test.QuickCheck hiding (sample)+import Test.Tasty+import Test.Tasty.HUnit (testCase)+import Test.Tasty.QuickCheck (testProperty)+import Web.HttpApiData (parseUrlPiece)++zipkinProps :: TestTree+zipkinProps = testGroup "ZipkinProps" $ [+ testProperty "traceId always at least 16 chars long" $+ \s -> maybe False ((<=) 16 . T.length) . parseMaybe ( withObject "" ( .: "traceId") ) $ toJSON (ZipkinSpan (s :: Span))+ , testProperty "traceId never longer than 32 chars" $+ \s -> maybe False ((>=) 32 . T.length) . parseMaybe ( withObject "" ( .: "traceId") ) $ toJSON (ZipkinSpan (s :: Span))+ , testProperty "spanId always 16 chars long" $+ \s -> maybe False ((==) 16 . T.length) . parseMaybe ( withObject "" (.: "id") ) $ toJSON (ZipkinSpan (s :: Span))+ ]+++zipkinSpec :: TestTree+zipkinSpec = testGroup "Zipkin Spec" $ [+ testCase "timestamp is in microseconds" $ do+ s <- generate arbitrary+ let fromMicros = maybe 0 (/ 1000000) . parseMaybe ( withObject "" (.: "timestamp") ) $ toJSON (ZipkinSpan (s :: Span))+ fromMicros @=? timestamp s+ , testCase "parentId set when a child Relation is present" $ do+ s <- generate arbitrary :: IO Span+ c <- generate arbitrary :: IO SpanContext+ let s' = s {relations = [ChildOf c]}+ let isPresent = maybe False (not . T.null) . parseMaybe ( withObject "" (.: "parentId") ) $ toJSON (ZipkinSpan s')+ isPresent @=? True+ , testCase "parentId set when a FollowsFrom Relation is present" $ do+ s <- generate arbitrary :: IO Span+ c <- generate arbitrary :: IO SpanContext+ let s' = s {relations = [FollowsFrom c]}+ let isPresent = maybe False (not . T.null) . parseMaybe ( withObject "" (.: "parentId") ) $ toJSON (ZipkinSpan s')+ isPresent @=? True+ , testCase "parentId unset when no Relation is present" $ do+ s <- generate arbitrary :: IO Span+ let s' = s {relations = []}+ let isPresent = maybe False (not . T.null) . parseMaybe ( withObject "" (.: "parentId") ) $ toJSON (ZipkinSpan s')+ isPresent @=? False+ ]+