servant-tracing 0.1.0.2 → 0.2.0.0

raw patch · 8 files changed

+55/−183 lines, 8 filesdep +http-typesdep −servant-serverdep −warpdep ~aesonPVP ok

version bump matches the API change (PVP)

Dependencies added: http-types

Dependencies removed: servant-server, warp

Dependency ranges changed: aeson

API changes (from Hackage documentation)

Files

• README.md +4/−3
• app/Main.hs +0/−115
• servant-tracing.cabal +7/−33
• src/Servant/Tracing.hs +1/−4
• src/Tracing/Core.hs +20/−13
• src/Tracing/DataDog.hs +13/−7
• src/Tracing/Zipkin.hs +0/−1
• test/Tracing/CoreSpec.hs +10/−7

@@ -2,7 +2,7 @@  [![Build Status](https://travis-ci.org/ChrisCoffey/haskell-opentracing-light.svg?branch=master)](https://travis-ci.org/ChrisCoffey/haskell-opentracing-light) -This repository is the minimum required for publishing trace data to Zipkin or Jaeger. It adheres to the [Open Tracing Standard] (https://github.com/opentracing/specification) but is not complete. See the documentation on Hackage for module-level details.+This repository is the minimum required for publishing trace data to Zipkin or Jaeger. It adheres to the [Open Tracing Standard](https://github.com/opentracing/specification) but is missing a few features. See the documentation on Hackage for module-level details.   ### Using the library@@ -25,12 +25,13 @@ ### Testing Locally with the Demo App  You can start up a compatible server for [Zipkin](https://zipkin.io/pages/quickstart.html) or [Jaeger](https://jaegertracing.netlify.com/docs/deployment/) via a standalone docker container. From there its a matter of seting the following environment variables:-- *TRACING_ENDPOINT*: a `String` with the fully url to a running tracing server+- *TRACING_ENDPOINT*: a `String` with the fully url to a running tracing server. For example, `http://localhost:9411/api/v2/spans` to publish to a Zipkin endpoint. - *TRACING_SERVICE*: a `String` name for your service +Once the a tracing server & the example service are running, you can interact with it via your favorite REST client. The api expects a header named `Auth`, and has two top level endpoints: `fast` & `slow`. Here's an example request: `curl localhost:8080/slow -HAUTH="foo"` + #### Pending Features-- Concurrent tracing support. - Thrift support - Additional clients - Pluggable samplers

@@ -1,115 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}-module Main where--import Servant.Tracing ( getInstructions, WithTracing)-import Tracing.Core (recordSpan,TracingInstructions(..), SpanRelationTag(..), Tracer(..), MonadTracer(..), SpanId(..),-    TraceId(..), debugPrintSpan)-import Tracing.Zipkin (publishZipkin)--import Control.Concurrent (threadDelay, forkIO)-import Control.Monad (forever, mapM_)-import Control.Monad.Trans (MonadIO, liftIO)-import Control.Monad.Trans.Control (MonadBaseControl)-import Control.Monad.Reader (ReaderT(..), ask, MonadReader)-import Data.IORef (IORef, newIORef, atomicModifyIORef')-import Data.Maybe (maybe)-import Data.Proxy (Proxy(..))-import Data.Foldable (toList)-import Data.ByteString.Char8 as BS-import Servant-import Servant.Server-import System.Environment (lookupEnv, getEnv)-import qualified Data.Text as T-import Network.Wai.Handler.Warp (run)-import Network.HTTP.Client (Manager, newManager, defaultManagerSettings, responseStatus, responseBody)---main :: IO ()-main = do-    debug <- maybe False (== "TRUE") <$> lookupEnv "TRACE_DEBUG"-    destinationPath <- getEnv "TRACING_ENDPOINT"-    svcName <- T.pack <$> getEnv "TRACING_SERVICE"-    httpManager <- newManager defaultManagerSettings-    cell <- newIORef []-    let tracer = Tracer cell svcName-    forkIO $ publishLoop destinationPath httpManager tracer-    run 8080 . serve (Proxy :: Proxy ExampleAPI) $ server tracer---publishLoop ::-    String-    -> Manager-    -> Tracer-    -> IO ()-publishLoop destination manager (Tracer {spanBuffer}) = forever $ do-    threadDelay 5000000-    buffer <- atomicModifyIORef' spanBuffer (\b -> ([], b))-    mResp <- publishZipkin destination manager $ toList buffer-    case mResp of-        Nothing -> pure ()-        Just resp -> do-            print $ "Ran Loop " ++ (show $ responseStatus resp) ++ " " ++ (show . fmap debugPrintSpan $ toList buffer)-            print $ "       " ++ (T.unpack $ responseBody resp)--------- API Definition-----type ExampleAPI =-    WithTracing :> MyAPI--type MyAPI =-    Header "Auth" T.Text :>-        (-        "fast" :> Get '[JSON] Int-        :<|>-        "slow" :> Get '[JSON] T.Text-        )-------- Server logic----server :: Tracer -> Server (WithTracing :> MyAPI)-server tracer inst auth =-    runFast-    :<|>-    runSlow-    where-        loadCtx = do-            instructions <- getInstructions True inst-            currSpan <- liftIO $ newIORef (spanId instructions)-            pure Ctx {-                tracer,-                currSpan,-                instructions-                }-        runFast = do-            ctx <- loadCtx-            runStack ctx $-                recordSpan (const Child <$> inst) [] "Run Fast" . liftIO $-                    threadDelay 1000000 *> pure 42-        runSlow = do-            ctx <- loadCtx-            runStack ctx $-                recordSpan (const Child <$> inst) [] "Run Slow" $ do-                    liftIO $ threadDelay 500000-                    let action = liftIO $ threadDelay 1500000 *> pure "Boo"-                    recordSpan (Just Child) [] "Slow Child" action--runStack :: Ctx -> ReaderT Ctx Handler a -> Handler a-runStack ctx action = runReaderT action ctx--data Ctx = Ctx {-    tracer :: Tracer,-    currSpan :: IORef SpanId,-    instructions :: TracingInstructions-    }--instance (Monad m, MonadBaseControl IO m, MonadIO m, MonadReader Ctx m) => MonadTracer m where-    getTracer = tracer <$> ask-    currentTrace = (traceId . instructions) <$> ask-    currentSpan = currSpan <$> ask-    isDebug = (debug . instructions) <$> ask

@@ -1,11 +1,11 @@ name:           servant-tracing-version:        0.1.0.2+version:        0.2.0.0 description:    Please see the README on Github at <https://github.com/ChrisCoffey/haskell-opentracing-light#readme> homepage:       https://github.com/ChrisCoffey/haskell-opentracing-light#readme bug-reports:    https://github.com/ChrisCoffey/haskell-opentracing-light/issues author:         Chris Coffey-maintainer:     chris@foldl.io-copyright:      2018 Chris Coffey+maintainer:     chris@coffey.dev+copyright:      2018-2021 Chris Coffey license:        MIT license-file:   LICENSE build-type:     Simple@@ -22,13 +22,12 @@ library   default-extensions:  DataKinds FlexibleContexts ScopedTypeVariables OverloadedStrings ViewPatterns NamedFieldPuns                        KindSignatures RecordWildCards ConstraintKinds TypeSynonymInstances FlexibleInstances-                       DuplicateRecordFields GeneralizedNewtypeDeriving InstanceSigs TypeFamilies+                       DuplicateRecordFields GeneralizedNewtypeDeriving InstanceSigs TypeFamilies MultiParamTypeClasses   hs-source-dirs:       src   build-depends:                 base >=4.7 && <5                 , servant-                , servant-server                 , containers                 , unordered-containers                 , time@@ -43,8 +42,9 @@                 , monad-control                 , lifted-base                 , http-api-data-                , aeson+                , aeson >= 2.0.1.0 && < 3                 , http-client+                , http-types   exposed-modules:                 Tracing.Core               , Tracing.Zipkin@@ -53,32 +53,6 @@   -- other-modules:   default-language: Haskell2010 -executable servant-tracing-example-  main-is: Main.hs-  hs-source-dirs:-      app-  default-extensions:  DataKinds FlexibleContexts ScopedTypeVariables OverloadedStrings ViewPatterns NamedFieldPuns-                       KindSignatures RecordWildCards ConstraintKinds TypeSynonymInstances FlexibleInstances-                       DuplicateRecordFields GeneralizedNewtypeDeriving InstanceSigs TypeFamilies TypeOperators-  ghc-options: -threaded -rtsopts -with-rtsopts=-N-  build-depends:-      base >=4.7 && <5-    , servant-tracing-    , servant-    , servant-server-    , bytestring-    , mtl-    , text-    , transformers-    , containers-    , wai-    , monad-control-    , lifted-base-    , warp-    , async-    , http-client-  default-language: Haskell2010- test-suite servant-tracing-test   type: exitcode-stdio-1.0   main-is: Spec.hs@@ -99,7 +73,7 @@     , tasty     , tasty-quickcheck     , tasty-hunit-    , aeson+    , aeson >= 2.0.1.0 && < 3     , containers     , time   other-modules:

@@ -1,6 +1,5 @@ {-# LANGUAGE RankNTypes #-} module Servant.Tracing (-    ServantTracingT,     WithTracing,     TracingInstructions(..),     instructionsToHeader,@@ -18,13 +17,11 @@ import Data.Bits (testBit, (.|.)) import Data.Maybe (catMaybes, fromMaybe) import Data.Monoid ((<>))-import Servant-import Servant.Server+import Servant.API.Header (Header) import System.Random (randomRIO) import Web.HttpApiData (FromHttpApiData(..))  -- | Constrain the 'ServerT''s base monad such that it provides an instance of 'MonadTracer'-type ServantTracingT api m = (MonadIO m, MonadTracer m) => ServerT api m type WithTracing = Header "uber-trace-id" TracingInstructions  

@@ -12,6 +12,7 @@     Tracer(..),     TracingInstructions(..),     MonadTracer(..),+    HasSpanId(..),     ToSpanTag(..),     Tag(..), @@ -22,6 +23,7 @@ import Control.Arrow ((&&&)) import Control.Exception.Lifted (bracket) import Control.Monad.Trans (liftIO, MonadIO)+import Control.Monad.Reader (MonadReader, ask, local) import Control.Monad.Trans.Control (MonadBaseControl) import Data.Text (Text) import qualified Data.Text as T@@ -51,20 +53,26 @@ newtype TraceId = TraceId Int64     deriving (Eq, Ord, Show, FromHttpApiData) +class HasSpanId a where+    getSpanId :: a -> SpanId+    setSpanId ::  a -> SpanId -> a+ -- | Indicates that the current monad can provide a 'Tracer' and related context. -- It assumes some form of environment. While this exposes some mutable state, all -- of it is hidden away behind the `recordSpan` api.-class Monad m => MonadTracer m where+class (Monad m, HasSpanId r, MonadReader r m) => MonadTracer m r where     getTracer :: m Tracer -- ^ 'Tracer' is global to the process     currentTrace :: m TraceId -- ^ Set during the initial request from the outside world, this is propagated across all nodes in the call-    currentSpan :: m (IORef SpanId) -- ^ Set via 'recordSpan'     isDebug :: m Bool -- ^ Set during the initial request from the outside world, this is propagated across all nodes in the call +    currentSpan :: m SpanId+    currentSpan = getSpanId <$> ask+ -- | Wraps a computation & writes it to the 'Tracer''s IORef. To start a new top-level span, and therefore -- a new trace, call this function with *spanType* == 'Nothing'. Otherwise, this will create a child span. -- -- Doesn't support parallel computations yet-recordSpan :: (MonadIO m, MonadBaseControl IO m, MonadTracer m) =>+recordSpan :: (MonadIO m, MonadBaseControl IO m, MonadTracer m r) =>     Maybe SpanRelationTag     -> [Tag]     -> OpName@@ -72,8 +80,7 @@     -> m a recordSpan spanType tags opName action = do     Tracer {svcName=serviceName, spanBuffer} <- getTracer-    currentSpanCell <- currentSpan-    activeSpanId <- liftIO $ readIORef currentSpanCell+    activeSpanId <- currentSpan     traceId <- currentTrace     debug <- isDebug @@ -97,21 +104,21 @@                         debug,                         serviceName                         }-            liftIO $ atomicModifyIORef' currentSpanCell (const (newSpanId, ()))-            pure $ ActiveSpan makeSpan+            pure $ ActiveSpan loggedSpanId makeSpan  -        closeSpan (ActiveSpan finishSpan) = do+        closeSpan (ActiveSpan _ finishSpan) = do             now <- liftIO getCurrentTime             let span = finishSpan now                 sid = spanId (context span :: SpanContext)             liftIO $ atomicModifyIORef' spanBuffer (\xs -> (span:xs, ()))-            liftIO $ atomicModifyIORef' currentSpanCell (const (activeSpanId, ())) +        runAction (ActiveSpan spanId _) =+            local (`setSpanId` spanId) action+     bracket startSpan             closeSpan-            (const action)-+            runAction     where         -- When this is a top level span, there should be no SpanRelationTag. These two functions work         -- together to ensure the spans nest properly@@ -135,8 +142,8 @@         sample :: !Bool         } deriving (Eq, Show) -newtype ActiveSpan =-    ActiveSpan {finishSpan :: UTCTime -> Span}+data ActiveSpan =+    ActiveSpan {asid :: SpanId, finishSpan :: UTCTime -> Span}  -- | Global context required for tracing. The `spanBuffer` should be manually drained by library users. data Tracer =

@@ -18,9 +18,12 @@ import qualified Data.Text.Encoding as T import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.Char8 as LBSC8 import qualified Data.ByteString.Lex.Integral as BS-import qualified Data.HashMap.Strict as HM import Network.HTTP.Client+import Network.HTTP.Types.Header (Header)+import Data.Aeson.Types (ToJSON(toJSON))+import qualified Data.Map as Map   -- | Publish 'Span' in the <https://docs.datadoghq.com/api/?lang=bash#send-traces DataDog format> . No call is made@@ -28,21 +31,25 @@ publishDataDog :: MonadIO m =>     String -- ^ The address of the backend server     -> Manager+    -> [Header]     -> [Span] -- ^ The traced spans to send to a DataDog backend     -> m (Maybe (Response T.Text))-publishDataDog _ _ [] = pure Nothing-publishDataDog destination manager spans =-    liftIO . fmap (Just . fmap decode) $ httpLbs zipkinReq manager+publishDataDog _ _ _ [] = pure Nothing+publishDataDog destination manager additionalHeaders spans =+    liftIO . fmap (Just . fmap decode) $ httpLbs ddReq manager     where         decode = T.decodeUtf8 . LBS.toStrict         req = parseRequest_ destination         body = RequestBodyLBS . encode $ DataDogSpan <$> spans-        zipkinReq = req { method = "POST", requestBody = body, requestHeaders = [("content-type", "application/json")]}+        ddReq = req { method = "POST",+                      requestBody = body,+                      requestHeaders = [("content-type", "application/json")] <> additionalHeaders+                    }  newtype DataDogSpan = DataDogSpan Span instance ToJSON DataDogSpan where     toJSON (DataDogSpan span) = object $ [-        "trace_id" .= (unTrace . traceId $ context span),+        "trace_id"  .= (unTrace . traceId $ context span),         "span_id" .= (unSpan . spanId $ context span),         "name" .=  unOp (operationName span),         "resource" .= unOp (operationName span),@@ -58,7 +65,6 @@             unOp (OpName n) = n             unSpan (SpanId sid) = sid             unTrace (TraceId tid) = tid-            parentId :: [SpanRelation] -> [(T.Text, Value)]             parentId (ChildOf ctx:_) = ["parent_id" .= (unSpan $ spanId ctx)]             parentId (FollowsFrom ctx:_) = ["parent_id" .= (unSpan $ spanId ctx)]             parentId _ = []

@@ -58,7 +58,6 @@             zipkinFormatId = padLeft 16 . T.pack . BS.unpack . fromMaybe "-1"             unTrace (TraceId t) = zipkinFormatId $ BS.packHexadecimal t             unSpan (SpanId s) = zipkinFormatId $ BS.packHexadecimal s-            parentId :: [SpanRelation] -> [(T.Text, Value)]             parentId (ChildOf ctx:_) = ["parentId" .= (unSpan $ spanId ctx)]             parentId (FollowsFrom ctx:_) = ["parentId" .= (unSpan $ spanId ctx)]             parentId _ = []

@@ -1,4 +1,4 @@-{-# LANGUAGE NamedFieldPuns, OverloadedStrings, UndecidableInstances, DuplicateRecordFields, FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns, OverloadedStrings, UndecidableInstances, DuplicateRecordFields, FlexibleInstances, MultiParamTypeClasses #-}  module Tracing.CoreSpec (     coreProps,@@ -93,10 +93,10 @@         ctx <- newContext         flip runReaderT ctx . recordSpan Nothing [] "Foo" $             recordSpan (Just Child) [] "Bar" $-            recordSpan (Just Child) [] "Baz"+            recordSpan (Just Child) [] "Baz" $ pure (7 + 8)         -- This test will break if 'recordSpan' changes significantly         [x, y, z] <- readIORef . spanBuffer $ tracer ctx-        let pid =+        let pid = x         ((sid $ context x) /= (sid $ context y)) @? "Sibling spans must have different ids"         -}     ]@@ -104,7 +104,7 @@ newContext :: IO Ctx newContext = do     cell <- newIORef []-    currSpan <- newIORef $ SpanId 1234+    let currSpan = SpanId 1234     pure Ctx {         tracer = Tracer cell "UNIT TESTING",         currSpan = currSpan,@@ -122,13 +122,16 @@  data Ctx = Ctx {     tracer :: Tracer,-    currSpan :: IORef SpanId,+    currSpan :: SpanId,     dbg :: Bool,     currTrace :: TraceId     } -instance (Monad m, MonadBaseControl IO m, MonadIO m, MonadReader Ctx m) => MonadTracer m where+instance HasSpanId Ctx where+    getSpanId = currSpan+    setSpanId c s = c {currSpan = s}++instance (Monad m, MonadBaseControl IO m, MonadIO m, MonadReader Ctx m) => MonadTracer m Ctx where     getTracer = tracer <$> ask     currentTrace = currTrace <$> ask-    currentSpan = currSpan <$> ask     isDebug = dbg <$> ask