diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for servant-tracing + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,31 @@ +# servant-tracing + +[![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/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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/servant-tracing.cabal b/servant-tracing.cabal new file mode 100644 --- /dev/null +++ b/servant-tracing.cabal @@ -0,0 +1,109 @@ +name: servant-tracing +version: 0.1.0.0 +description: Please see the README on Github at +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 diff --git a/src/Servant/Tracing.hs b/src/Servant/Tracing.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Tracing.hs @@ -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 diff --git a/src/Tracing/Core.hs b/src/Tracing/Core.hs new file mode 100644 --- /dev/null +++ b/src/Tracing/Core.hs @@ -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 diff --git a/src/Tracing/Zipkin.hs b/src/Tracing/Zipkin.hs new file mode 100644 --- /dev/null +++ b/src/Tracing/Zipkin.hs @@ -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 diff --git a/test/Instances.hs b/test/Instances.hs new file mode 100644 --- /dev/null +++ b/test/Instances.hs @@ -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 + } + diff --git a/test/Servant/TracingSpec.hs b/test/Servant/TracingSpec.hs new file mode 100644 --- /dev/null +++ b/test/Servant/TracingSpec.hs @@ -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) + ] + + + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 + ] diff --git a/test/Tracing/CoreSpec.hs b/test/Tracing/CoreSpec.hs new file mode 100644 --- /dev/null +++ b/test/Tracing/CoreSpec.hs @@ -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 diff --git a/test/Zipkin/ClientSpec.hs b/test/Zipkin/ClientSpec.hs new file mode 100644 --- /dev/null +++ b/test/Zipkin/ClientSpec.hs @@ -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 + ] +