opentracing (empty) → 0.1.0.0
raw patch · 18 files changed
+2439/−0 lines, 18 filesdep +aesondep +asyncdep +base
Dependencies added: aeson, async, base, base64-bytestring, bytestring, case-insensitive, clock, containers, http-types, iproute, lens, mtl, mwc-random, network, safe-exceptions, semigroups, stm, text, time, transformers, unordered-containers, uri-bytestring, vinyl
Files
- CHANGELOG.md +3/−0
- LICENSE +202/−0
- OpenTracing.hs +183/−0
- OpenTracing/Log.hs +132/−0
- OpenTracing/Propagation.hs +233/−0
- OpenTracing/Reporting.hs +10/−0
- OpenTracing/Reporting/Batch.hs +172/−0
- OpenTracing/Reporting/Pure.hs +66/−0
- OpenTracing/Reporting/Stdio.hs +69/−0
- OpenTracing/Sampling.hs +89/−0
- OpenTracing/Span.hs +424/−0
- OpenTracing/Standard.hs +131/−0
- OpenTracing/Tags.hs +331/−0
- OpenTracing/Time.hs +23/−0
- OpenTracing/Tracer.hs +152/−0
- OpenTracing/Types.hs +128/−0
- README.md +18/−0
- opentracing.cabal +73/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+* 0.1.0.0 (2012-04-20)++After years of friendly reminders, a zero version gets finally released =]
+ LICENSE view
@@ -0,0 +1,202 @@++ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright [yyyy] [name of copyright owner]++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ OpenTracing.hs view
@@ -0,0 +1,183 @@+{-|+Module: OpenTracing++The [OpenTracing spec](https://github.com/opentracing/specification/blob/master/specification.md) defines a platform agnostic approach for distributed tracing. Distributed+tracing gives us insights into how complex programs spread across multiple processes are+performing together.++This package provides a core implementation of the OpenTracing spec. It includes+functionality to++ * Create `Span`s describing application code executions, including `Tag`s and+ `LogRecord`s++ * Serialize and deserialize `SpanContext`s across process boundaries++ * Batch and log `FinishedSpan`s++It does not provide any functionality for consuming `Span`s. There are platform specific+backends (CloudTrace, Zipkin, Jaeger, etc) that are provided in other packages.++-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StrictData #-}++module OpenTracing+ ( -- * Distributed tracing+ -- | These are mtl style constraints and runners for working with tracers in+ -- a distributed environment. When traces cross process boundaries (for example+ -- in an RPC call, information about the `SpanContext` needs to be transmitted+ -- from one process to another, so that all `Span`s in the same trace can be+ -- reported in the same trace forest.+ --+ -- To satisfy these constraints, you have to have access to a `Propagation` in+ -- the application environment, which manages serialization and deserialization of+ -- `SpanContext`s.+ HasOpenTracing+ , MonadOpenTracing+ , runOpenTracing++ -- * Local tracing+ -- | If you aren't tracing a distributed system, these simpler constraints+ -- will work. The only thing required is a `Tracer.Tracer` in the application+ -- context. If the program execution crosses process boundaries, no serialization+ -- will be performed.+ , MonadTracer+ , Tracer.Tracer(..)+ , Tracer.HasTracer(..)+ , Tracer.runTracer++ -- * Tracing functions+ -- | Functions to trace application code+ , traced+ , traced_+ , startSpan+ , finishSpan++ -- * Propagation+ -- | Functions for serialization and deserialization in a distributed tracing+ -- environment+ , extract+ , inject++ -- * Additional modules+ , module OpenTracing.Log+ , module OpenTracing.Propagation+ , module OpenTracing.Sampling+ , module OpenTracing.Span+ , module OpenTracing.Tags+ , module OpenTracing.Types+ )+where++import Control.Exception.Safe+import Control.Lens+import Control.Monad.IO.Class+import Control.Monad.Reader+import OpenTracing.Log+import OpenTracing.Propagation hiding (inject, extract)+import qualified OpenTracing.Propagation as Propagation+import OpenTracing.Sampling+import OpenTracing.Span+import OpenTracing.Tags+import qualified OpenTracing.Tracer as Tracer+import OpenTracing.Types+import Prelude hiding (span)+++type HasOpenTracing r p = (Tracer.HasTracer r, HasPropagation r p)+type MonadOpenTracing r p m = (HasOpenTracing r p, MonadReader r m)+type MonadTracer r m = (Tracer.HasTracer r, MonadReader r m)+type MonadPropagation r p m = (HasPropagation r p, MonadReader r m)+++runOpenTracing :: HasOpenTracing r p => r -> ReaderT r m a -> m a+runOpenTracing = flip runReaderT++-- | Trace a computation as a span. This is a high-level operation that will handle+-- all aspects of the trace, including timing and reporting. If the traced computation+-- throws an excpetion, `traced` will clean up and add logs before rethrowing the+-- exception+--+-- @+-- traced (spanOpts "hello" mempty ) $ \parent ->+-- traced (spanOpts "world" (childOf parent)) $ \child ->+-- liftIO $ do+-- putStrLn "doing some work..."+-- addLogRecord child (Message "doing some work")+-- threadDelay 500000+-- @+--+traced+ :: ( MonadTracer r m+ , MonadMask m+ , MonadIO m+ )+ => SpanOpts+ -- ^ The options to use when creating the span. Options include:+ --+ -- * Operation name+ --+ -- * Tags+ --+ -- * Relations to other spans+ -> (ActiveSpan -> m a)+ -- ^ the computation to trace. The argument is the+ -- span that is created. It can be used to:+ --+ -- * Add logs+ --+ -- * Add child spans+ -> m (Traced a)+traced opt f = view Tracer.tracer >>= \t -> Tracer.traced t opt f++-- | Variant of `traced` that doesn't return the wrapped value.+traced_+ :: ( MonadTracer r m+ , MonadMask m+ , MonadIO m+ )+ => SpanOpts+ -> (ActiveSpan -> m a)+ -> m a+traced_ opt f = tracedResult <$> traced opt f++startSpan+ :: ( MonadTracer r m+ , MonadIO m+ )+ => SpanOpts+ -> m ActiveSpan+startSpan opt = view Tracer.tracer >>= flip Tracer.startSpan opt++finishSpan+ :: ( MonadTracer r m+ , MonadIO m+ )+ => ActiveSpan+ -> m FinishedSpan+finishSpan a = view Tracer.tracer >>= flip Tracer.finishSpan a++-- | Serialize a `SpanContext` into the format `c` using a serializer from+-- the application context. See `OpenTracing.Propagation` for more info.+inject+ :: forall c r p m.+ ( MonadPropagation r p m+ , HasCarrier c p+ )+ => SpanContext+ -> m c+inject ctx = flip Propagation.inject ctx <$> view propagation++-- | Attempt to deserialize a `SpanContext` from the format @c@ using a deserializer+-- from the application context. See `OpenTracing.Propagation` for more info.+extract+ :: forall c r p m.+ ( MonadPropagation r p m+ , HasCarrier c p+ )+ => c+ -> m (Maybe SpanContext)+extract c = flip Propagation.extract c <$> view propagation
+ OpenTracing/Log.hs view
@@ -0,0 +1,132 @@+{-|+Module: OpenTracing.Log++Logs are structured data that occur over the lifetime of a span.+-}++{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TemplateHaskell #-}++module OpenTracing.Log+ ( LogRecord(..)+ , logTime+ , logFields++ , LogField(..)+ , logFieldLabel+ , logFieldEncoding+ , logFieldValue++ , LogFieldsFormatter+ , jsonAssoc+ , jsonMap+ )+where++import Control.Exception+import Control.Lens hiding ((.=))+import Data.Aeson+import qualified Data.Aeson.Encoding as Encoding+import Data.ByteString.Builder (Builder)+import Data.Foldable+import Data.List.NonEmpty (NonEmpty)+import Data.Text (Text)+import Data.Time.Clock+import GHC.Stack+import qualified Data.Map.Strict as Map++-- | A single entry into a `Spans` logs. Occurs at a single time and contains multiple+-- (one or more) entries.+--+-- @since 0.1.0.0+data LogRecord = LogRecord+ { _logTime :: UTCTime+ , _logFields :: NonEmpty LogField+ } deriving Show++-- | A piece of data in a `LogRecord`. Conceptually a key:value pair with a few+-- distinguished keys. More info about the distinguished keys in the [OpenTracing spec](https://github.com/opentracing/specification/blob/master/semantic_conventions.md#log-fields-table)+--+-- @since 0.1.0.0+data LogField where+ -- | A generic key:value pair entry into a `LogRecord`+ LogField :: Show a => Text -> a -> LogField++ -- | A stable identifier for some notable moment in the lifetime of a Span.+ Event :: Text -> LogField++ -- | A concise, human-readable, one-line message explaining the event.+ Message :: Text -> LogField++ -- | A stack trace in platform-conventional format+ Stack :: CallStack -> LogField++ -- | The type or "kind" of an error (only for event="error" logs).+ ErrKind :: Text -> LogField++ -- | The actual error exception+ ErrObj :: Exception e => e -> LogField++deriving instance (Show LogField)++type LogFieldsFormatter = forall t. Foldable t => t LogField -> Builder++-- | A log formatter that encodes each `LogField` as a single JSON object.+--+-- >>> BS.hPutBuilder stdout $ jsonAssoc [Event "e", LogField @Text "key" "value"]+-- [{"event":"\"e\""},{"key":"\"value\""}]+--+-- @since 0.1.0.0+jsonAssoc :: LogFieldsFormatter+jsonAssoc = Encoding.fromEncoding . Encoding.list go . toList+ where+ go lf = Encoding.pairs $+ Encoding.pair (logFieldLabel lf) (logFieldEncoding lf)++-- | A log formatter that encodes each `LogField` as an entry in a shared JSON object+--+-- >>> BS.hPutBuilder stdout $ jsonMap [Event "e", LogField @Text "key" "value"]+-- {"event":"e","key":"\"value\""}+--+-- @since 0.1.0.0+jsonMap :: LogFieldsFormatter+jsonMap+ = Encoding.fromEncoding+ . Encoding.dict Encoding.text id Map.foldrWithKey'+ . foldr' merge mempty+ where+ merge lf = Map.insert (logFieldLabel lf) (logFieldEncoding lf)++-- | Retrieve the label of a log field. Distinguished `LogField`s have predefined keys.+--+-- @since 0.1.0.0+logFieldLabel :: LogField -> Text+logFieldLabel (LogField x _) = x+logFieldLabel (Event _) = "event"+logFieldLabel (Message _) = "message"+logFieldLabel (Stack _) = "stack"+logFieldLabel (ErrKind _) = "error.kind"+logFieldLabel (ErrObj _) = "error.object"++logFieldEncoding :: LogField -> Encoding+logFieldEncoding (LogField _ v) = Encoding.string $ show v+logFieldEncoding (Event v) = Encoding.text v+logFieldEncoding (Message v) = Encoding.text v+logFieldEncoding (Stack v) = Encoding.string $ prettyCallStack v+logFieldEncoding (ErrKind v) = Encoding.text v+logFieldEncoding (ErrObj v) = Encoding.string $ show v++logFieldValue :: LogField -> Value+logFieldValue (LogField _ v) = toJSON $ show v+logFieldValue (Event v) = toJSON v+logFieldValue (Message v) = toJSON v+logFieldValue (Stack v) = toJSON $ prettyCallStack v+logFieldValue (ErrKind v) = toJSON v+logFieldValue (ErrObj v) = toJSON $ show v+++makeLenses ''LogRecord
+ OpenTracing/Propagation.hs view
@@ -0,0 +1,233 @@+{-|+Module: OpenTracing.Propagation++Types and functions for serializing and deserializing `SpanContext`s across+process boundaries.++One of the big motiviating use cases for propagation is for tracing distributed+executions through RPC calls.+-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module OpenTracing.Propagation+ ( TextMap+ , Headers+-- , Binary++ , Propagation+ , HasPropagation(..)++ , Carrier(..)+ , HasCarrier+ , HasCarriers+ , carrier++ , inject+ , extract++ , otPropagation+ , b3Propagation++ , _OTTextMap+ , _OTHeaders+ , _B3TextMap+ , _B3Headers++ , _HeadersTextMap++ -- * Re-exports from 'Data.Vinyl'+ , Rec ((:&), RNil)+ , rappend, (<+>)+ , rcast+ )+where++import Control.Applicative ((<|>))+import Control.Lens+import Data.Bool (bool)+import Data.ByteString.Builder (toLazyByteString)+import qualified Data.CaseInsensitive as CI+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.Maybe (catMaybes)+import Data.Monoid+import Data.Proxy+import Data.Text (Text, isPrefixOf, toLower)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import qualified Data.Text.Read as Text+import Data.Vinyl+import Data.Word+import Network.HTTP.Types (Header)+import OpenTracing.Span+import OpenTracing.Types+import URI.ByteString (urlDecodeQuery, urlEncodeQuery)+++type TextMap = HashMap Text Text+type Headers = [Header]+--type Binary = Lazy.ByteString++-- | A `Propagation` contains the different ways that a `SpanContext` can be+-- serialized and deserialized. For example @Propagation '[TextMap, Headers]@ indicates+-- support for serializing to `Header` or to `TextMap`.+--+-- @since 0.1.0.0+type Propagation carriers = Rec Carrier carriers++-- | A typeclass for application environments that contain a `Propagation`.+--+-- @since 0.1.0.0+class HasPropagation a p | a -> p where+ propagation :: Getting r a (Propagation p)++instance HasPropagation (Propagation p) p where+ propagation = id++-- | `Carrier a` is a way to convert a `SpanContext` into or from an `a`.+--+-- @since 0.1.0.0+newtype Carrier a = Carrier { fromCarrier :: Prism' a SpanContext }++type HasCarrier c cs = c ∈ cs+type HasCarriers cs ds = cs ⊆ ds++-- | Retrieve a (de)serialization lens from the application context for+-- format @c@.+--+-- @since 0.1.0.0+carrier+ :: ( HasCarrier c cs+ , HasPropagation r cs+ )+ => proxy c -- ^ Proxy for the carrier type @c@.+ -> r -- ^ The application context+ -> Prism' c SpanContext+carrier _c = fromCarrier . view (propagation . rlens)++-- | Serialize a `SpanContext` into the format `c` using a serializer from+-- the application context.+--+-- @since 0.1.0.0+inject+ :: forall c r p.+ ( HasCarrier c p+ , HasPropagation r p+ )+ => r+ -> SpanContext+ -> c+inject r = review (carrier (Proxy @c) r)++-- | Attempt to deserialize a `SpanContext` from the format @c@ using a deserializer+-- from the application context+--+-- @since 0.1.0.0+extract+ :: forall c r p.+ ( HasCarrier c p+ , HasPropagation r p+ )+ => r+ -> c+ -> Maybe SpanContext+extract r = preview (carrier (Proxy @c) r)+++-- | A propagation using an "ot" prefix.+-- No parent span id is propagated in OT.+otPropagation :: Propagation '[TextMap, Headers]+otPropagation = Carrier _OTTextMap :& Carrier _OTHeaders :& RNil++-- | A propagation using an "x-b3" prefix for use with Zipkin.+b3Propagation :: Propagation '[TextMap, Headers]+b3Propagation = Carrier _B3TextMap :& Carrier _B3Headers :& RNil+++_OTTextMap :: Prism' TextMap SpanContext+_OTTextMap = prism' fromCtx toCtx+ where+ fromCtx c@SpanContext{..} = HashMap.fromList $+ ("ot-tracer-traceid", view hexText ctxTraceID)+ : ("ot-tracer-spanid" , view hexText ctxSpanID)+ : ("ot-tracer-sampled", view (ctxSampled . re _OTSampled) c)+ : map (over _1 ("ot-baggage-" <>)) (HashMap.toList _ctxBaggage)++ toCtx m = SpanContext+ <$> (HashMap.lookup "ot-tracer-traceid" m >>= preview _Hex . knownHex)+ <*> (HashMap.lookup "ot-tracer-spanid" m >>= preview _Hex . knownHex)+ <*> pure Nothing -- nb. parent is not propagated in OT+ <*> (HashMap.lookup "ot-tracer-sampled" m >>= preview _OTSampled)+ <*> pure (HashMap.filterWithKey (\k _ -> "ot-baggage-" `isPrefixOf` k) m)+++_OTHeaders :: Prism' Headers SpanContext+_OTHeaders = _HeadersTextMap . _OTTextMap++_OTSampled :: Prism' Text Sampled+_OTSampled = prism' enc dec+ where+ enc = \case Sampled -> "1"+ _ -> "0"++ dec = either (const Nothing) id+ . fmap (\(x,_) -> Just $ if x == (1 :: Word8) then Sampled else NotSampled)+ . Text.decimal++_B3TextMap :: Prism' TextMap SpanContext+_B3TextMap = prism' fromCtx toCtx+ where+ fromCtx ctx@SpanContext{..} = HashMap.fromList . catMaybes $+ Just ("x-b3-traceid", view hexText ctxTraceID)+ : Just ("x-b3-spanid" , view hexText ctxSpanID)+ : fmap (("x-b3-parentspanid",) . view hexText) ctxParentSpanID+ : Just ("x-b3-sampled", bool "false" "true" $ view (ctxSampled . re _IsSampled) ctx)+ : map (Just . over _1 ("ot-baggage-" <>)) (HashMap.toList _ctxBaggage)++ toCtx m = SpanContext+ <$> (HashMap.lookup "x-b3-traceid" m >>= preview _Hex . knownHex)+ <*> (HashMap.lookup "x-b3-spanid" m >>= preview _Hex . knownHex)+ <*> (Just $ HashMap.lookup "x-b3-parentspanid" m >>= preview _Hex . knownHex)+ <*> (b3Sampled m <|> b3Debug m <|> Just NotSampled)+ <*> pure (HashMap.filterWithKey (\k _ -> "ot-baggage-" `isPrefixOf` k) m)++ b3Sampled m = HashMap.lookup "x-b3-sampled" m >>= \case+ "true" -> Just Sampled+ _ -> Nothing++ b3Debug m = HashMap.lookup "x-b3-flags" m >>= \case+ "1" -> Just Sampled+ _ -> Nothing++_B3Headers :: Prism' Headers SpanContext+_B3Headers = _HeadersTextMap . _B3TextMap++-- | Convert between a 'TextMap' and 'Headers'+--+-- Header field values are URL-encoded when converting from 'TextMap' to+-- 'Headers', and URL-decoded when converting the other way.+--+-- Note: validity of header fields is not checked (RFC 7230, 3.2.4)+_HeadersTextMap :: Iso' Headers TextMap+_HeadersTextMap = iso toTextMap toHeaders+ where+ toHeaders+ = map (bimap (CI.mk . encodeUtf8)+ (view strict . toLazyByteString . urlEncodeQuery . encodeUtf8))+ . HashMap.toList++ toTextMap+ = HashMap.fromList+ . map (bimap (toLower . decodeUtf8 . CI.original)+ (decodeUtf8 . urlDecodeQuery))
+ OpenTracing/Reporting.hs view
@@ -0,0 +1,10 @@+module OpenTracing.Reporting+ ( module OpenTracing.Reporting.Batch+ , module OpenTracing.Reporting.Pure+ , module OpenTracing.Reporting.Stdio+ )+where++import OpenTracing.Reporting.Batch+import OpenTracing.Reporting.Pure+import OpenTracing.Reporting.Stdio
+ OpenTracing/Reporting/Batch.hs view
@@ -0,0 +1,172 @@+{-|+Module: OpenTracing.Reporting.Batch++This module provides a trace reporter that groups recorded spans into batches+before sending them to their destination in bulk.++-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++module OpenTracing.Reporting.Batch+ ( BatchOptions+ , batchOptions+ , boptBatchSize+ , boptTimeoutSec+ , boptReporter+ , boptErrorLog++ , defaultErrorLog++ , BatchEnv+ , newBatchEnv+ , closeBatchEnv++ , batchReporter+ )+where++import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Exception (AsyncException (ThreadKilled))+import Control.Exception.Safe+import Control.Lens+import Control.Monad+import Control.Monad.IO.Class+import Data.ByteString.Builder+import Data.Semigroup+import Data.Time (NominalDiffTime)+import Data.Word+import OpenTracing.Span+import OpenTracing.Time+import System.IO (stderr)+import System.Timeout++-- | Options available to construct a batch reporter. Default options are+-- available with `batchOptions`+data BatchOptions = BatchOptions+ { _boptBatchSize :: Word16+ -- ^ The maximum number of elements to report in a batch. Default 100+ , _boptTimeoutSec :: Word+ -- ^ The maximum time (in seconds) to wait while reporting a batch before erroring.+ -- Default 5 seconds.+ , _boptReporter :: [FinishedSpan] -> IO ()+ -- ^ The function to call with the batch of spans. Has an upper bound on size equal+ -- to _boptBatchSize. No default.+ , _boptErrorLog :: Builder -> IO ()+ -- ^ What to do with errors. Default print to stderr.+ }++-- | Default batch options which can be overridden via lenses.+batchOptions :: ([FinishedSpan] -> IO ()) -> BatchOptions+batchOptions f = BatchOptions+ { _boptBatchSize = 100+ , _boptTimeoutSec = 5+ , _boptReporter = f+ , _boptErrorLog = defaultErrorLog+ }++-- | An error logging function which prints to stderr.+defaultErrorLog :: Builder -> IO ()+defaultErrorLog = hPutBuilder stderr++makeLenses ''BatchOptions+++-- | The environment of a batch reporter.+data BatchEnv = BatchEnv+ { envQ :: TQueue FinishedSpan+ -- ^ The queue of spans to be reported+ , envRep :: Async ()+ -- ^ Asynchronous consumer of the queue+ }++-- | Create a new batch environment+newBatchEnv :: BatchOptions -> IO BatchEnv+newBatchEnv opt = do+ q <- newTQueueIO+ BatchEnv q <$> consumer opt q++-- | Close a batch reporter, stop consuming any new spans. Any+-- spans in the queue will be drained.+closeBatchEnv :: BatchEnv -> IO ()+closeBatchEnv = cancel . envRep++-- | An implementation of `OpenTracing.Tracer.tracerReport` that batches the finished+-- spans for transimission to their destination.+batchReporter :: MonadIO m => BatchEnv -> FinishedSpan -> m ()+batchReporter BatchEnv{envQ} = liftIO . atomically . writeTQueue envQ++consumer :: BatchOptions -> TQueue FinishedSpan -> IO (Async ())+consumer opt@BatchOptions{..} q = async . forever $ do+ xs <- popBlocking+ go False xs+ where+ popBlocking = atomically $ do+ x <- readTQueue q+ (x:) <$> pop (_boptBatchSize - 1) q++ popNonblock = atomically $ pop _boptBatchSize q++ go _ [] = pure ()+ go True batch = report batch *> drain+ go False batch = withAsync (report batch) $ \a ->+ timedWait a `catchAsync` \case+ ThreadKilled -> do+ logErr opt ErrReporterCancelled+ timedWait a `finally` uninterruptibleCancel a+ drain+ throwM ThreadKilled++ e -> logErr opt (ErrReporterAsyncException e) *> throwM e++ report batch = _boptReporter batch `catchAny`+ (logErr opt . ErrReporterException)++ timedWait a = timeout timeoutMicros (wait a) >>= \case+ Nothing -> logErr opt ErrReporterTimeout+ _ -> pure ()++ drain = do+ logErr opt ErrReporterDraining+ popNonblock >>= go True++ timeoutMicros = micros @NominalDiffTime $ fromIntegral _boptTimeoutSec+++pop :: Word16 -> TQueue a -> STM [a]+pop 0 _ = pure []+pop n q = do+ v <- tryReadTQueue q+ case v of+ Nothing -> pure []+ Just v' -> (v' :) <$> pop (n-1) q++data Err+ = ErrReporterException SomeException+ | ErrReporterTimeout+ | ErrReporterCancelled+ | ErrReporterAsyncException AsyncException+ | ErrReporterDraining++logErr :: BatchOptions -> Err -> IO ()+logErr BatchOptions{_boptErrorLog=errlog} e = errlog $ msg e <> nl+ where+ sbs = shortByteString++ ebs :: Exception e => e -> Builder+ ebs = string8 . show++ msg = \case+ ErrReporterException ex -> sbs "Reporter Error: " <> ebs ex+ ErrReporterTimeout -> sbs "Reporter timed out!"+ ErrReporterCancelled -> sbs "Batch reporter cancelled, shutting down gracefully"+ ErrReporterAsyncException ex -> sbs "Batch reporter received async exception: " <> ebs ex+ ErrReporterDraining -> sbs "Draining batch reporter queue"++ nl = char8 '\n'
+ OpenTracing/Reporting/Pure.hs view
@@ -0,0 +1,66 @@+{-|+Module: OpenTracing.Reporting.Pure++Reporters with no external components.+-}++{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}++module OpenTracing.Reporting.Pure+ ( noReporter+ , memReporter+ , newMem+ , newBoundedMem+ , memPeek+ , memTake+ )+where++import Control.Monad.IO.Class+import Data.IORef+import Data.Word+import OpenTracing.Span++-- | A null reporter which ignores anything it's given.+noReporter :: MonadIO m => FinishedSpan -> m ()+noReporter = const $ pure ()++-- | A reporter which stores the finished spans in memory where+-- they wait to be consumed.+memReporter :: MonadIO m => Mem -> FinishedSpan -> m ()+memReporter m = liftIO . memAppend m++-- | Mem reporter state.+data Mem = Mem+ { siz :: Maybe Word32+ , vec :: IORef [FinishedSpan]+ }++-- | Construct a new `memReporter` environment that can store an unbounded+-- seequence of `FinishedSpan`s.+newMem :: IO Mem+newMem = Mem Nothing <$> newIORef []++-- | Construct a new `memReporter` environment that stores a bounded+-- sequence of `FinishedSpan`s+newBoundedMem :: Word32 -> IO Mem+newBoundedMem s = Mem (Just s) <$> newIORef []++memAppend :: Mem -> FinishedSpan -> IO ()+memAppend Mem{..} x = atomicModifyIORef' vec $ \xs ->+ let xs' = case siz of+ Nothing -> x : xs+ Just 0 -> []+ Just 1 -> [x]+ Just s -> x : take (fromIntegral s - 1) xs+ in (xs', ())++-- | View the `FinishedSpans` in a `memReporter` without removing them.+memPeek :: Mem -> IO [FinishedSpan]+memPeek Mem{vec} = readIORef vec++-- | View and remove the `FinishedSpans` in a `memReporter`.+memTake :: Mem -> IO [FinishedSpan]+memTake Mem{vec} = atomicModifyIORef' vec $ (,) []
+ OpenTracing/Reporting/Stdio.hs view
@@ -0,0 +1,69 @@+{-|+Module: OpenTracing.Reporting.Stdio++Logging reporters that emit spans to stdout, stderr and System.IO `Handles`.+-}+{-# LANGUAGE OverloadedStrings #-}++module OpenTracing.Reporting.Stdio+ ( stdoutReporter+ , stderrReporter+ , stdioReporter+ )+where++import Control.Lens (view)+import Control.Monad.IO.Class+import Data.Aeson (toEncoding)+import Data.Aeson.Encoding+import Data.ByteString.Lazy.Char8 (hPutStrLn)+import Data.Foldable (toList)+import Data.Semigroup ((<>))+import GHC.Stack (prettyCallStack)+import OpenTracing.Log+import OpenTracing.Span+import System.IO (Handle, stderr, stdout)++-- | Implementation of `OpenTracing.Tracer.tracerReport` that logs `FinishedSpan`s to+-- stdout+stdoutReporter :: MonadIO m => FinishedSpan -> m ()+stdoutReporter = stdioReporter stdout++-- | Implementation of `OpenTracing.Tracer.tracerReport` that logs `FinishedSpan`s to+-- stderr+stderrReporter :: MonadIO m => FinishedSpan -> m ()+stderrReporter = stdioReporter stderr++-- | Implementation of `OpenTracing.Tracer.tracerReport` that logs `FinishedSpan`s to+-- a `Handle`.+stdioReporter :: MonadIO m => Handle -> FinishedSpan -> m ()+stdioReporter h = liftIO . hPutStrLn h . encodingToLazyByteString . spanE+++spanE :: FinishedSpan -> Encoding+spanE s = pairs $+ pair "operation" (text $ view spanOperation s)+ <> pair "start" (utcTime $ view spanStart s)+ <> pair "duration" (double . realToFrac $ view spanDuration s)+ <> pair "context" (toEncoding $ view spanContext s)+ <> pair "references" (list refE . toList $ view spanRefs s)+ <> pair "tags" (toEncoding $ view spanTags s)+ <> pair "logs" (list logRecE . reverse $ view spanLogs s)++refE :: Reference -> Encoding+refE (ChildOf ctx) = pairs . pair "child_of" . toEncoding $ ctx+refE (FollowsFrom ctx) = pairs . pair "follows_from" . toEncoding $ ctx++logRecE :: LogRecord -> Encoding+logRecE r = pairs $+ pair "time" (utcTime (view logTime r))+ <> pair "fields" (list logFieldE . toList $ view logFields r)++logFieldE :: LogField -> Encoding+logFieldE f = pairs . pair (logFieldLabel f) $ case f of+ Event x -> text x+ Message x -> text x+ Stack x -> string . prettyCallStack $ x+ ErrKind x -> text x+ ErrObj x -> string . show $ x+ LogField _ x -> string . show $ x
+ OpenTracing/Sampling.hs view
@@ -0,0 +1,89 @@+{-|+Module: OpenTracing.Sampling++Distributed traces are sampled, meaning they (and the spans that make them up) are+selected to either be reported or not.++This module defines a few different ways to determine if a given trace should be+sampled.+-}++{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE ViewPatterns #-}++module OpenTracing.Sampling+ ( Sampler(..)+ , constSampler+ , probSampler+ , rateLimitSampler+ )+where++import Control.Monad.IO.Class+import Data.IORef+import Data.Text (Text)+import OpenTracing.Types (TraceID (..))+import System.Clock++-- | A `Sampler` is an algorithm for determine if a trace should be reported.+newtype Sampler = Sampler+ { runSampler :: forall m. MonadIO m => TraceID -> Text -> m Bool+ -- ^ Run a sampler, providing it a trace id and the operation of the span.+ }++-- | A `Sampler` that always returns the given value. Useful for debug environments.+constSampler :: Bool -> Sampler+constSampler x = Sampler $ \_ _ -> pure x++-- | A `Sampler` that randomly chooses to report a given percentage of traces. The+-- source of randomness is the ID of the trace.+probSampler+ :: Double -- ^ A probability percentage, between 0.0 and 1.0+ -> Sampler+probSampler (max 0.0 . min 1.0 -> rate) = Sampler $ \trace _ ->+ pure $ boundary >= traceIdLo trace+ where+ boundary = round $ maxRand * rate+ maxRand = 0x7fffffffffffffff++-- | A `Sampler` that will report the given number of traces per second.+rateLimitSampler+ :: Double -- ^ Traces per second+ -> IO Sampler+rateLimitSampler tps = do+ lim <- newRateLimiter tps (max 1.0 tps)+ return $ Sampler $ \_ _ -> liftIO $ haveCredit lim 1.0++data RateLimiter = RateLimiter+ { creds :: Double+ , balance :: IORef Double+ , maxBalance :: Double+ , lastTick :: IORef TimeSpec+ , timeNow :: IO TimeSpec+ }++newRateLimiter :: Double -> Double -> IO RateLimiter+newRateLimiter creds maxb = RateLimiter+ <$> pure creds+ <*> newIORef maxb+ <*> pure maxb+ <*> (tnow >>= newIORef)+ <*> pure tnow+ where+ tnow = getTime Monotonic++haveCredit :: RateLimiter -> Double -> IO Bool+haveCredit RateLimiter{..} cost = do+ now <- timeNow+ (lst,t) <- atomicModifyIORef' lastTick $ \x ->+ if now > x then (now,(x,now)) else (x,(x,x))++ atomicModifyIORef' balance $ \bal -> do+ let elapsed = diffTimeSpec lst t+ let bal' = min maxBalance (bal + (realToFrac (sec elapsed) * creds))+ if bal' >= cost then+ (bal' - cost, True)+ else+ (bal', False)
+ OpenTracing/Span.hs view
@@ -0,0 +1,424 @@+{-|+Module: OpenTracing.Span++Data types and functions for manipulating [spans](https://github.com/opentracing/specification/blob/master/specification.md#span)+-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++module OpenTracing.Span+ ( SpanContext(..)+ , ctxSampled+ , ctxBaggage++ , Span+ , newSpan++ , HasSpanFields++ , ActiveSpan+ , mkActive+ , modifyActiveSpan+ , readActiveSpan+ , addTag+ , addLogRecord+ , addLogRecord'+ , setBaggageItem+ , getBaggageItem++ , FinishedSpan+ , spanFinish++ , spanContext+ , spanOperation+ , spanStart+ , spanTags+ , spanRefs+ , spanLogs+ , spanDuration++ , SpanOpts+ , spanOpts+ , spanOptOperation+ , spanOptRefs+ , spanOptTags+ , spanOptSampled++ , Reference(..)+ , findParent++ , SpanRefs+ , refActiveParents+ , refPredecessors+ , refPropagated+ , childOf+ , followsFrom+ , freezeRefs++ , Sampled(..)+ , _IsSampled+ , sampled++ , Traced(..)+ )+where++import Control.Applicative+import Control.Lens hiding (op, pre, (.=))+import Control.Monad.IO.Class+import Data.Aeson (ToJSON (..), object, (.=))+import Data.Aeson.Encoding (int, pairs)+import Data.Bool (bool)+import Data.Foldable+import Data.HashMap.Strict (HashMap, insert)+import Data.IORef+import Data.List.NonEmpty (NonEmpty (..))+import Data.Semigroup+import Data.Text (Text)+import Data.Time.Clock+import Data.Word+import OpenTracing.Log+import OpenTracing.Tags+import OpenTracing.Types+import Prelude hiding (span)++-- | A `SpanContext` is the data that uniquely identifies a span+-- and the context in which it occurs. Spans occur in traces, which form+-- complete pictures of a computation, potentially across multiple machines.+--+-- @since 0.1.0.0+data SpanContext = SpanContext+ { ctxTraceID :: TraceID+ -- ^ A trace identifier. Trace ids are globally unique+ , ctxSpanID :: Word64+ -- ^ A span identifier. Span identifiers are unique to their trace.+ , ctxParentSpanID :: Maybe Word64+ -- ^ Spans without a parent are known as "root spans"+ , _ctxSampled :: Sampled+ -- ^ Whether or not this span is going to be reported.+ , _ctxBaggage :: HashMap Text Text+ -- ^ Baggage is arbitrary key:value pairs that cross process boundaries.+ }++instance ToJSON SpanContext where+ toEncoding SpanContext{..} = pairs $+ "trace_id" .= view hexText ctxTraceID+ <> "span_id" .= view hexText ctxSpanID+ <> "sampled" .= _ctxSampled+ <> "baggage" .= _ctxBaggage++ toJSON SpanContext{..} = object+ [ "trace_id" .= view hexText ctxTraceID+ , "span_id" .= view hexText ctxSpanID+ , "sampled" .= _ctxSampled+ , "baggage" .= _ctxBaggage+ ]++-- | A wrapper for a value that was produced by a traced computation.+--+-- @since 0.1.0.0+data Traced a = Traced+ { tracedResult :: a+ -- ^ The raw value produced+ , tracedSpan :: ~FinishedSpan+ -- ^ The resulting span that was created+ }++-- | A datatype indicating whether a recorded span was sampled, i.e. whether or not+-- it will be reported. Traces are often sampled in high volume environments to keep+-- the amount of data generated manageable.+--+-- @since 0.1.0.0+data Sampled = NotSampled | Sampled+ deriving (Eq, Show, Read, Bounded, Enum)++instance ToJSON Sampled where+ toJSON = toJSON . fromEnum+ toEncoding = int . fromEnum++_IsSampled :: Iso' Bool Sampled+_IsSampled = iso (bool NotSampled Sampled) $ \case+ Sampled -> True+ NotSampled -> False++-- | A reference from one span to another. Spans can be related in two ways:+--+-- * `ChildOf` indicates that the parent span is dependent on the child span in order+-- to produce its own result.+--+-- * `FollowsFrom` indicates that there is no dependence relation, perhaps the+-- parent span spawned an asynchronous task.+--+-- More info in the [OpenTracing spec](https://github.com/opentracing/specification/blob/master/specification.md#references-between-spans)+--+-- @since 0.1.0.0+data Reference+ = ChildOf { refCtx :: SpanContext }+ | FollowsFrom { refCtx :: SpanContext }++findParent :: Foldable t => t Reference -> Maybe Reference+findParent = foldl' go Nothing+ where+ go Nothing y = Just y+ go (Just x) y = Just $ case prec x y of { LT -> y; _ -> x }++ prec (ChildOf _) (FollowsFrom _) = GT+ prec (FollowsFrom _) (ChildOf _) = LT+ prec _ _ = EQ++-- | The different references that a span can hold to other spans.+--+-- @since 0.1.0.0+data SpanRefs = SpanRefs+ { _refActiveParents :: [ActiveSpan ]+ -- ^ Parent span references. `ActiveSpans` are still in progress (parent spans by+ -- definition depend on their children to complete)+ , _refPredecessors :: [FinishedSpan]+ -- ^ Spans that this span `FollowsFrom`+ , _refPropagated :: [Reference ]+ -- ^ References that are propagated across process boundaries. Can be either parents+ -- or predecessors.+ }++instance Semigroup SpanRefs where+ (SpanRefs par pre pro) <> (SpanRefs par' pre' pro') = SpanRefs+ { _refActiveParents = par <> par'+ , _refPredecessors = pre <> pre'+ , _refPropagated = pro <> pro'+ }++instance Monoid SpanRefs where+ mempty = SpanRefs mempty mempty mempty+ mappend = (<>)++-- | Create a `SpanRefs` containing the single refrence to a parent span.+--+-- @since 0.1.0.0+childOf :: ActiveSpan -> SpanRefs+childOf a = mempty { _refActiveParents = [a] }++-- | Create a `SpanRefs` containing the single refrence to a predecessor span.+--+-- @since 0.1.0.0+followsFrom :: FinishedSpan -> SpanRefs+followsFrom a = mempty { _refPredecessors = [a] }++-- | Convert `SpanRefs` (which may include the mutable `ActiveSpan`s) into+-- an immutable list of `Reference`s+--+-- @since 0.1.0.0+freezeRefs :: SpanRefs -> IO [Reference]+freezeRefs SpanRefs{..} = do+ a <- traverse (fmap (ChildOf . _sContext) . readActiveSpan) _refActiveParents+ let b = map (FollowsFrom . _fContext) _refPredecessors+ return $ a <> b <> _refPropagated++-- | `SpanOpts` is the metadata information about a span needed in order to start+-- measuring a span. This is the information that application code will provide in+-- order to indicate what a span is doing and how it related to other spans. More info+-- in the [OpenTracing spec](https://github.com/opentracing/specification/blob/master/specification.md#start-a-new-span)+--+-- @since 0.1.0.0+data SpanOpts = SpanOpts+ { _spanOptOperation :: Text+ -- ^ The span operation, a human-readable string which concisely represents the+ -- work done by the Span+ , _spanOptRefs :: SpanRefs+ -- ^ Zero or more references to related spans. Zero references indicates that+ -- a span is a root span and should be given a new trace ID.+ , _spanOptTags :: [Tag]+ -- ^ Tags describing the work done by the span in more detail than the operation+ -- provides.+ , _spanOptSampled :: Maybe Sampled+ -- ^ Force 'Span' to be sampled (or not).+ -- 'Nothing' denotes leave decision to 'Sampler' (the default)+ }++-- | Create a new `SpanOpts` with the minimal amount of required information.+--+-- @since 0.1.0.0+spanOpts :: Text -> SpanRefs -> SpanOpts+spanOpts op refs = SpanOpts+ { _spanOptOperation = op+ , _spanOptRefs = refs+ , _spanOptTags = mempty+ , _spanOptSampled = Nothing+ }++-- | `Span` is a span that has been started (but not finished). See the [OpenTracing spec](https://github.com/opentracing/specification/blob/master/specification.md#span) for+-- more info+--+-- @since 0.1.0.0+data Span = Span+ { _sContext :: SpanContext+ -- ^ The context in which a span occurs+ , _sOperation :: Text+ -- ^ The operation that describes a span (see `SpanOpts` for more info)+ , _sStart :: UTCTime+ -- ^ The time that the span started+ , _sTags :: Tags+ -- ^ Tags describing the span in more detail than the operation.+ , _sRefs :: SpanRefs+ -- ^ References the span holds to other spans+ , _sLogs :: [LogRecord]+ -- ^ Structured data the describe events over the lifetime of the span+ }++-- | Create a new `Span` with the provided info. The created `Span` will have a start+-- time equal to the system time when `newSpan` is called.+--+-- @since 0.1.0.0+newSpan+ :: ( MonadIO m+ , Foldable t+ )+ => SpanContext+ -> Text+ -> SpanRefs+ -> t Tag+ -> m Span+newSpan ctx op refs ts = do+ t <- liftIO getCurrentTime+ pure Span+ { _sContext = ctx+ , _sOperation = op+ , _sStart = t+ , _sTags = foldMap (`setTag` mempty) ts+ , _sRefs = refs+ , _sLogs = mempty+ }++-- | A mutable `Span` that is currently being recorded.+--+-- @since 0.1.0.0+newtype ActiveSpan = ActiveSpan { fromActiveSpan :: IORef Span }++-- | @since 0.1.0.0+mkActive :: MonadIO m => Span -> m ActiveSpan+mkActive = fmap ActiveSpan . liftIO . newIORef++-- | @since 0.1.0.0+modifyActiveSpan :: MonadIO m => ActiveSpan -> (Span -> Span) -> m ()+modifyActiveSpan ActiveSpan{fromActiveSpan} f =+ liftIO $ atomicModifyIORef' fromActiveSpan ((,()) . f)++-- | @since 0.1.0.0+readActiveSpan :: MonadIO m => ActiveSpan -> m Span+readActiveSpan = liftIO . readIORef . fromActiveSpan++-- | A span that has finished executing.+--+-- @since 0.1.0.0+data FinishedSpan = FinishedSpan+ { _fContext :: SpanContext+ , _fOperation :: Text+ , _fStart :: UTCTime+ , _fDuration :: NominalDiffTime+ , _fTags :: Tags+ , _fRefs :: [Reference]+ , _fLogs :: [LogRecord]+ }++-- | Convert an unfinished `Span` into a `FinishedSpan`+--+-- @since 0.1.0.0+spanFinish :: MonadIO m => Span -> m FinishedSpan+spanFinish s = do+ (t,refs) <- liftIO $ liftA2 (,) getCurrentTime (freezeRefs (_sRefs s))+ pure FinishedSpan+ { _fContext = _sContext s+ , _fOperation = _sOperation s+ , _fStart = _sStart s+ , _fDuration = diffUTCTime t (_sStart s)+ , _fTags = _sTags s+ , _fRefs = refs+ , _fLogs = _sLogs s+ }++makeLenses ''SpanContext+makeLenses ''SpanOpts+makeLenses ''Span+makeLenses ''FinishedSpan+makeLenses ''SpanRefs++class HasSpanFields a where+ spanContext :: Lens' a SpanContext+ spanOperation :: Lens' a Text+ spanStart :: Lens' a UTCTime+ spanTags :: Lens' a Tags+ spanLogs :: Lens' a [LogRecord]++instance HasSpanFields Span where+ spanContext = sContext+ spanOperation = sOperation+ spanStart = sStart+ spanTags = sTags+ spanLogs = sLogs++instance HasSpanFields FinishedSpan where+ spanContext = fContext+ spanOperation = fOperation+ spanStart = fStart+ spanTags = fTags+ spanLogs = fLogs++class HasSampled a where+ sampled :: Lens' a Sampled++instance HasSampled Sampled where+ sampled = id++instance HasSampled SpanContext where+ sampled = ctxSampled++instance HasSampled Span where+ sampled = spanContext . sampled++instance HasSampled FinishedSpan where+ sampled = spanContext . sampled+++class HasRefs s a | s -> a where+ spanRefs :: Lens' s a++instance HasRefs Span SpanRefs where+ spanRefs = sRefs++instance HasRefs FinishedSpan [Reference] where+ spanRefs = fRefs+++spanDuration :: Lens' FinishedSpan NominalDiffTime+spanDuration = fDuration++addTag :: MonadIO m => ActiveSpan -> Tag -> m ()+addTag s t = liftIO $ do+ modifyActiveSpan s $ over spanTags (setTag t)++-- | Log structured data to an `ActiveSpan`. More info in the [OpenTracing spec](https://github.com/opentracing/specification/blob/master/specification.md#log-structured-data)+--+-- @since 0.1.0.0+addLogRecord :: MonadIO m => ActiveSpan -> LogField -> m ()+addLogRecord s f = addLogRecord' s f []++addLogRecord' :: MonadIO m => ActiveSpan -> LogField -> [LogField] -> m ()+addLogRecord' s f fs = liftIO $ do+ t <- getCurrentTime+ modifyActiveSpan s $+ over spanLogs (LogRecord t (f :| fs):)++setBaggageItem :: MonadIO m => ActiveSpan -> Text -> Text -> m ()+setBaggageItem s k v = modifyActiveSpan s $+ over (spanContext . ctxBaggage) (insert k v)++getBaggageItem :: MonadIO m => ActiveSpan -> Text -> m (Maybe Text)+getBaggageItem s k = view (spanContext . ctxBaggage . at k) <$> readActiveSpan s
+ OpenTracing/Standard.hs view
@@ -0,0 +1,131 @@+{-|+Module: OpenTracing.Standard++Standard implementations of `OpenTracing.Tracer` fields.+-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TemplateHaskell #-}++module OpenTracing.Standard+ ( StdEnv+ , newStdEnv+ , envTraceID128bit+ , envSampler++ , stdTracer+ , stdReporter+ )+where++import Control.Concurrent (MVar, newMVar, withMVar)+import Control.Lens hiding (Context, (.=))+import Control.Monad.Reader+import Data.Monoid+import Data.Word+import OpenTracing.Reporting.Stdio (stdoutReporter)+import OpenTracing.Sampling (Sampler (runSampler))+import OpenTracing.Span+import OpenTracing.Types+import Prelude hiding (putStrLn)+import System.Random.MWC++-- | A standard environment for generating trace and span IDs.+data StdEnv = StdEnv+ { envPRNGRef :: MVar GenIO+ , _envSampler :: Sampler+ , _envTraceID128bit :: Bool+ }++newStdEnv :: MonadIO m => Sampler -> m StdEnv+newStdEnv samp = do+ prng <- liftIO createSystemRandom+ prngRef <- liftIO $ newMVar prng+ return StdEnv { envPRNGRef = prngRef, _envSampler = samp, _envTraceID128bit = True }++makeLenses ''StdEnv++-- | A standard implementation of `OpenTracing.Tracer.tracerStart`.+stdTracer :: MonadIO m => StdEnv -> SpanOpts -> m Span+stdTracer r = flip runReaderT r . start++-- | A implementation of `OpenTracing.Tracer.tracerReport` that logs spans to stdout.+stdReporter :: MonadIO m => FinishedSpan -> m ()+stdReporter = stdoutReporter++--------------------------------------------------------------------------------+-- Internal++start :: (MonadIO m, MonadReader StdEnv m) => SpanOpts -> m Span+start so = do+ ctx <- do+ p <- findParent <$> liftIO (freezeRefs (view spanOptRefs so))+ case p of+ Nothing -> freshContext so+ Just p' -> fromParent (refCtx p')+ newSpan ctx+ (view spanOptOperation so)+ (view spanOptRefs so)+ (view spanOptTags so)++newTraceID :: (MonadIO m, MonadReader StdEnv m) => m TraceID+newTraceID = do+ StdEnv{..} <- ask+ liftIO $ withMVar envPRNGRef $ \prng -> do+ hi <- if _envTraceID128bit then+ Just <$> liftIO (uniform prng)+ else+ pure Nothing+ lo <- liftIO $ uniform prng+ return TraceID { traceIdHi = hi, traceIdLo = lo }++newSpanID :: (MonadIO m, MonadReader StdEnv m) => m Word64+newSpanID = do+ prngRef <- asks envPRNGRef+ liftIO $ withMVar prngRef $ \prng -> do+ uniform prng++freshContext+ :: ( MonadIO m+ , MonadReader StdEnv m+ )+ => SpanOpts+ -> m SpanContext+freshContext so = do+ trid <- newTraceID+ spid <- newSpanID+ smpl <- view envSampler++ sampled' <- case view spanOptSampled so of+ Nothing -> view _IsSampled+ <$> runSampler smpl trid (view spanOptOperation so)+ Just s -> pure s++ return SpanContext+ { ctxTraceID = trid+ , ctxSpanID = spid+ , ctxParentSpanID = Nothing+ , _ctxSampled = sampled'+ , _ctxBaggage = mempty+ }++fromParent+ :: ( MonadIO m+ , MonadReader StdEnv m+ )+ => SpanContext+ -> m SpanContext+fromParent p = do+ spid <- newSpanID+ return SpanContext+ { ctxTraceID = ctxTraceID p+ , ctxSpanID = spid+ , ctxParentSpanID = Just (ctxSpanID p)+ , _ctxSampled = view ctxSampled p+ , _ctxBaggage = view ctxBaggage p+ }
+ OpenTracing/Tags.hs view
@@ -0,0 +1,331 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures #-}++module OpenTracing.Tags+ ( Tags(fromTags)+ , Tag+ , TagVal(..)+ , setTag+ , getTag+ , getTagReify++ -- * Standard span tags.+ -- | Refer to the [OpenTracing spec](https://github.com/opentracing/specification/blob/master/semantic_conventions.md#span-tags-table)+ -- for more info.+ , pattern ComponentKey+ , pattern DbInstanceKey+ , pattern DbStatementKey+ , pattern DbTypeKey+ , pattern DbUserKey+ , pattern ErrorKey+ , pattern HttpMethodKey+ , pattern HttpStatusCodeKey+ , pattern HttpUrlKey+ , pattern MessageBusDestinationKey+ , pattern PeerAddressKey+ , pattern PeerHostnameKey+ , pattern PeerIPv4Key+ , pattern PeerIPv6Key+ , pattern PeerPortKey+ , pattern PeerServiceKey+ , pattern SamplingPriorityKey+ , pattern SpanKindKey++ , pattern Component+ , pattern DbInstance+ , pattern DbStatement+ , pattern DbType+ , pattern DbUser+ , pattern Error+ , pattern HttpMethod+ , pattern HttpStatusCode+ , pattern HttpUrl+ , pattern MessageBusDestination+ , pattern PeerAddress+ , pattern PeerHostname+ , pattern PeerIPv4+ , pattern PeerIPv6+ , pattern PeerPort+ , pattern PeerService+ , pattern SamplingPriority+ , pattern SpanKind++ , _Component+ , _DbInstance+ , _DbStatement+ , _DbType+ , _DbUser+ , _Error+ , _HttpMethod+ , _HttpStatusCode+ , _HttpUrl+ , _MessageBusDestination+ , _PeerAddress+ , _PeerHostname+ , _PeerIPv4+ , _PeerIPv6+ , _PeerPort+ , _PeerService+ , _SamplingPriority+ , _SpanKind++ , SpanKinds(..)+ , spanKindLabel+ )+where++import Control.Lens+import Data.Aeson (ToJSON (..))+import Data.Aeson.Encoding+import qualified Data.ByteString.Base64.Lazy as B64+import qualified Data.ByteString.Lazy as Lazy+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.Int (Int64)+import Data.Monoid (First)+import Data.Semigroup (Semigroup)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import qualified Data.Text.Lazy.Encoding as Lazy+import Data.Word (Word8)+import Network.HTTP.Types+import OpenTracing.Types+import Text.Read (readMaybe)++-- | Tags are structured data associated with a `OpenTracing.Span.Span`. They can give+-- a more complete picture of what a Span is doing than the operation alone. Tags+-- apply to the entire timerange of a Span. Use `OpenTracing.Log.LogField` for+-- events that refer to particular timestamp.+newtype Tags = Tags { fromTags :: HashMap Text TagVal }+ deriving (Eq, Show, Semigroup, Monoid, ToJSON)++-- | A Tag is a key:value pair+type Tag = (Text, TagVal)++data TagVal+ = BoolT Bool+ | StringT Text+ | IntT Int64+ | DoubleT Double+ | BinaryT Lazy.ByteString+ deriving (Eq, Show)++instance ToJSON TagVal where+ toJSON (BoolT x) = toJSON x+ toJSON (StringT x) = toJSON x+ toJSON (IntT x) = toJSON x+ toJSON (DoubleT x) = toJSON x+ toJSON (BinaryT x) = toJSON . Lazy.decodeUtf8 . B64.encode $ x++ toEncoding (BoolT x) = toEncoding x+ toEncoding (StringT x) = toEncoding x+ toEncoding (IntT x) = toEncoding x+ toEncoding (DoubleT x) = toEncoding x+ toEncoding (BinaryT x) = toEncoding . Lazy.decodeUtf8 . B64.encode $ x++setTag :: Tag -> Tags -> Tags+setTag (k,v) = Tags . HashMap.insert k v . fromTags++getTag :: Text -> Tags -> Maybe TagVal+getTag k = HashMap.lookup k . fromTags++-- | Get a tag and attempt to convert it from a serialized format+getTagReify :: Getting (First b) Tag b -> Text -> Tags -> Maybe b+getTagReify p k ts = getTag k ts >>= preview p . (k,)+++pattern ComponentKey = "component"+pattern DbInstanceKey = "db.instance"+pattern DbStatementKey = "db.statement"+pattern DbTypeKey = "db.type"+pattern DbUserKey = "db.user"+pattern ErrorKey = "error"+pattern HttpMethodKey = "http.method"+pattern HttpStatusCodeKey = "http.status_code"+pattern HttpUrlKey = "http.url"+pattern MessageBusDestinationKey = "message_bus.destination"+pattern PeerAddressKey = "peer.address"+pattern PeerHostnameKey = "peer.hostname"+pattern PeerIPv4Key = "peer.ipv4"+pattern PeerIPv6Key = "peer.ipv6"+pattern PeerPortKey = "peer.port"+pattern PeerServiceKey = "peer.service"+pattern SamplingPriorityKey = "sampling.priority"+pattern SpanKindKey = "span.kind"++_Component :: Prism' Tag Text+_Component = prism' ((ComponentKey,) . StringT) $ \case+ (k, StringT v) | k == ComponentKey -> Just v+ _ -> Nothing++pattern Component v <- (preview _Component -> Just v) where+ Component v = review _Component v++_DbInstance :: Prism' Tag Text+_DbInstance = prism' ((DbInstanceKey,) . StringT) $ \case+ (k, StringT v) | k == DbInstanceKey -> Just v+ _ -> Nothing++pattern DbInstance v <- (preview _DbInstance -> Just v) where+ DbInstance v = review _DbInstance v++_DbStatement :: Prism' Tag Text+_DbStatement = prism' ((DbStatementKey,) . StringT) $ \case+ (k, StringT v) | k == DbStatementKey -> Just v+ _ -> Nothing++pattern DbStatement v <- (preview _DbStatement -> Just v) where+ DbStatement v = review _DbStatement v++_DbType :: Prism' Tag Text+_DbType = prism' ((DbTypeKey,) . StringT) $ \case+ (k, StringT v) | k == DbTypeKey -> Just v+ _ -> Nothing++pattern DbType v <- (preview _DbType -> Just v) where+ DbType v = review _DbType v++_DbUser :: Prism' Tag Text+_DbUser = prism' ((DbUserKey,) . StringT) $ \case+ (k, StringT v) | k == DbUserKey -> Just v+ _ -> Nothing++pattern DbUser v <- (preview _DbUser -> Just v) where+ DbUser v = review _DbUser v++_Error :: Prism' Tag Bool+_Error = prism' ((ErrorKey,) . BoolT) $ \case+ (k, BoolT v) | k == ErrorKey -> Just v+ _ -> Nothing++pattern Error v <- (preview _Error -> Just v) where+ Error v = review _Error v++_HttpUrl :: Prism' Tag Text+_HttpUrl = prism' ((HttpUrlKey,) . StringT) $ \case+ (k, StringT v) | k == HttpUrlKey -> Just v+ _ -> Nothing++pattern HttpUrl v <- (preview _HttpUrl -> Just v) where+ HttpUrl v = review _HttpUrl v++_MessageBusDestination :: Prism' Tag Text+_MessageBusDestination = prism' ((MessageBusDestinationKey,) . StringT) $ \case+ (k, StringT v) | k == MessageBusDestinationKey -> Just v+ _ -> Nothing++pattern MessageBusDestination v <- (preview _MessageBusDestination -> Just v) where+ MessageBusDestination v = review _MessageBusDestination v++_PeerAddress :: Prism' Tag Text+_PeerAddress = prism' ((PeerAddressKey,) . StringT) $ \case+ (k, StringT v) | k == PeerAddressKey -> Just v+ _ -> Nothing++pattern PeerAddress v <- (preview _PeerAddress -> Just v) where+ PeerAddress v = review _PeerAddress v++_PeerHostname :: Prism' Tag Text+_PeerHostname = prism' ((PeerHostnameKey,) . StringT) $ \case+ (k, StringT v) | k == PeerHostnameKey -> Just v+ _ -> Nothing++pattern PeerHostname v <- (preview _PeerHostname -> Just v) where+ PeerHostname v = review _PeerHostname v++_PeerService :: Prism' Tag Text+_PeerService = prism' ((PeerServiceKey,) . StringT) $ \case+ (k, StringT v) | k == PeerServiceKey -> Just v+ _ -> Nothing++pattern PeerService v <- (preview _PeerService -> Just v) where+ PeerService v = review _PeerService v++_HttpMethod :: Prism' Tag Method+_HttpMethod = prism' ((HttpMethodKey,) . StringT . decodeUtf8) $ \case+ (k, StringT (encodeUtf8 -> x)) | k == HttpMethodKey ->+ either (const Nothing) (const (Just x)) $ parseMethod x+ _ -> Nothing++pattern HttpMethod v <- (preview _HttpMethod -> Just v) where+ HttpMethod v = review _HttpMethod v++_HttpStatusCode :: Prism' Tag Status+_HttpStatusCode = prism' ((HttpStatusCodeKey,) . IntT . fromIntegral . statusCode) $ \case+ (k, IntT x) | k == HttpStatusCodeKey -> Just . toEnum . fromIntegral $ x+ _ -> Nothing++pattern HttpStatusCode v <- (preview _HttpStatusCode -> Just v) where+ HttpStatusCode v = review _HttpStatusCode v++_PeerIPv4 :: Prism' Tag IPv4+_PeerIPv4 = prism' ((PeerIPv4Key,) . StringT . Text.pack . show) $ \case+ (k, StringT x) | k == PeerIPv4Key -> readMaybe (Text.unpack x)+ _ -> Nothing++pattern PeerIPv4 v <- (preview _PeerIPv4 -> Just v) where+ PeerIPv4 v = review _PeerIPv4 v++_PeerIPv6 :: Prism' Tag IPv6+_PeerIPv6 = prism' ((PeerIPv6Key,) . StringT . Text.pack . show) $ \case+ (k, StringT x) | k == PeerIPv6Key -> readMaybe (Text.unpack x)+ _ -> Nothing++pattern PeerIPv6 v <- (preview _PeerIPv6 -> Just v) where+ PeerIPv6 v = review _PeerIPv6 v++_PeerPort :: Prism' Tag Port+_PeerPort = prism' ((PeerPortKey,) . IntT . fromIntegral . fromPort) $ \case+ (k, IntT x) | k == PeerPortKey -> Just . toEnum . fromIntegral $ x+ _ -> Nothing++pattern PeerPort v <- (preview _PeerPort -> Just v) where+ PeerPort v = review _PeerPort v++_SamplingPriority :: Prism' Tag Word8+_SamplingPriority = prism' ((SamplingPriorityKey,) . IntT . fromIntegral) $ \case+ (k, IntT x) | k == SamplingPriorityKey -> Just . fromIntegral $ x+ _ -> Nothing++pattern SamplingPriority v <- (preview _SamplingPriority -> Just v) where+ SamplingPriority v = review _SamplingPriority v++_SpanKind :: Prism' Tag SpanKinds+_SpanKind = prism' ((SpanKindKey,) . StringT . spanKindLabel) $ \case+ (k, StringT x) | k == SpanKindKey -> fromSpanKindLabel x+ _ -> Nothing++pattern SpanKind v <- (preview _SpanKind -> Just v) where+ SpanKind = review _SpanKind++data SpanKinds+ = RPCClient+ | RPCServer+ | Producer+ | Consumer+ deriving (Eq, Show, Ord)++spanKindLabel :: SpanKinds -> Text+spanKindLabel RPCClient = "CLIENT"+spanKindLabel RPCServer = "SERVER"+spanKindLabel Producer = "PRODUCER"+spanKindLabel Consumer = "CONSUMER"++fromSpanKindLabel :: Text -> Maybe SpanKinds+fromSpanKindLabel "CLIENT" = Just RPCClient+fromSpanKindLabel "SERVER" = Just RPCServer+fromSpanKindLabel "PRODUCER" = Just Producer+fromSpanKindLabel "CONSUMER" = Just Consumer+fromSpanKindLabel _ = Nothing++instance ToJSON SpanKinds where+ toJSON = toJSON . spanKindLabel+ toEncoding = text . spanKindLabel
+ OpenTracing/Time.hs view
@@ -0,0 +1,23 @@+module OpenTracing.Time (AsMicros(micros)) where++import Data.Int+import Data.Time.Clock+import Data.Time.Clock.POSIX+import Data.Word+++class AsMicros a where+ micros :: Integral b => a -> b++instance AsMicros UTCTime where+ micros = round . (1000000*) . utcTimeToPOSIXSeconds+ {-# INLINE micros #-}++instance AsMicros NominalDiffTime where+ micros = round . (1000000*)+ {-# INLINE micros #-}++{-# SPECIALIZE micros :: UTCTime -> Int64 #-}+{-# SPECIALIZE micros :: UTCTime -> Word64 #-}+{-# SPECIALIZE micros :: NominalDiffTime -> Int64 #-}+{-# SPECIALIZE micros :: NominalDiffTime -> Word64 #-}
+ OpenTracing/Tracer.hs view
@@ -0,0 +1,152 @@+{-|+Module: OpenTracing.Tracer++This module provides mid and high level tracing functions.+-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StrictData #-}++module OpenTracing.Tracer+ ( Tracer(..)+ , HasTracer(..)+ , runTracer++ , traced+ , traced_+ , startSpan+ , finishSpan+ )+where++import Control.Exception.Safe+import Control.Lens+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Reader+import Data.List.NonEmpty (NonEmpty (..))+import Data.Time.Clock (getCurrentTime)+import OpenTracing.Log+import OpenTracing.Span+import OpenTracing.Tags+import Prelude hiding (span)++-- | A `Tracer` is a set of effectful actions that define the mid-level interface+-- to an [OpenTracing tracer](https://github.com/opentracing/specification/blob/master/specification.md#tracer)+--+-- Appliction code should generally construct a `Tracer` once and then use other+-- higher-level functions such as `traced`, `startSpan`, `finishedSpan`.+--+-- @since 0.1.0.0+data Tracer = Tracer+ { tracerStart :: forall m. MonadIO m => SpanOpts -> m Span+ -- ^ Start recording a new span with the given options. This is+ -- a mid-level operation that will handle start timing and random span ID+ -- generation.+ --+ -- Application code should supply this field with `stdTracer`.+ , tracerReport :: forall m. MonadIO m => FinishedSpan -> m ()+ -- ^ Report a finished span. What reporting means for each application will+ -- depend on where this data is going. There are multiple backends that define+ -- reporters for Google Cloudtrace, Zipkin, and Jaeger, for example.+ }++-- | Typeclass for application environments that contain a `Tracer`.+--+-- @since 0.1.0.0+class HasTracer a where+ tracer :: Getting r a Tracer++instance HasTracer Tracer where+ tracer = id++runTracer :: HasTracer r => r -> ReaderT r m a -> m a+runTracer = flip runReaderT++-- | Trace a computation as a span. This is a high-level operation that will handle+-- all aspects of the trace, including timing and reporting. If the traced computation+-- throws an excpetion, `traced` will clean up and add logs before rethrowing the+-- exception+--+-- @+-- traced tracer (spanOpts "hello" mempty ) $ \parent ->+-- traced tracer (spanOpts "world" (childOf parent)) $ \child ->+-- liftIO $ do+-- putStrLn "doing some work..."+-- addLogRecord child (Message "doing some work")+-- threadDelay 500000+-- @+--+-- @since 0.1.0.0+traced+ :: ( HasTracer t+ , MonadMask m+ , MonadIO m+ )+ => t -- ^ A tracer environment+ -> SpanOpts -- ^ The options to use when creating the span. Options include:+ --+ -- * Operation name+ --+ -- * Tags+ --+ -- * Relations to other spans+ -> (ActiveSpan -> m a) -- ^ the computation to trace. The argument is the+ -- span that is created. It can be used to:+ --+ -- * Add logs+ --+ -- * Add child spans+ -> m (Traced a)+traced t opt f = do+ span <- startSpan t opt+ -- /Note/: as per 'withException', we will be reporting any exception incl.+ -- async ones. Exceptions thrown by 'finishSpan'' will be ignored, and the+ -- one from 'f' will be rethrown. Observe that 'withException' does _not_+ -- run the error handler under `uninterruptibleMask', unlike 'bracket'. This+ -- is a good thing, as we might be doing blocking I/O.+ ret <- withException (f span) (onErr span >=> void . finishSpan t)+ fin <- finishSpan t span+ return Traced { tracedResult = ret, tracedSpan = fin }+ where+ onErr :: MonadIO m => ActiveSpan -> SomeException -> m ActiveSpan+ onErr span e = liftIO $ do+ now <- getCurrentTime+ modifyActiveSpan span $+ over spanTags (setTag (Error True))+ . over spanLogs (LogRecord now (ErrObj e :| []) :)+ pure span++-- | Variant of `traced` that doesn't return the wrapped value.+--+-- @since 0.1.0.0+traced_+ :: ( HasTracer t+ , MonadMask m+ , MonadIO m+ )+ => t+ -> SpanOpts+ -> (ActiveSpan -> m a)+ -> m a+traced_ t opt f = tracedResult <$> traced t opt f++-- | Start recording a span+--+-- @since 0.1.0.0+startSpan :: (HasTracer t, MonadIO m) => t -> SpanOpts -> m ActiveSpan+startSpan t opt = do+ let Tracer{tracerStart} = view tracer t+ tracerStart opt >>= liftIO . mkActive++-- | Finish recording a span+--+-- @since 0.1.0.0+finishSpan :: (HasTracer t, MonadIO m) => t -> ActiveSpan -> m FinishedSpan+finishSpan t a = do+ let Tracer{tracerReport} = view tracer t+ span <- liftIO (readActiveSpan a) >>= spanFinish+ case view sampled span of+ Sampled -> tracerReport span+ NotSampled -> return () -- TODO: record metric+ return span
+ OpenTracing/Types.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}++module OpenTracing.Types+ ( TraceID(..)+ , IPv4(..)+ , IPv6(..)+ , Port(..)++ , Protocol(..)+ , Addr(..)+ , addrHostName+ , addrPort+ , addrSecure++ , Hex+ , knownHex++ , AsHex(..)+ , hexText+ )+where++import Control.Lens+import Data.Aeson (ToJSON (..))+import Data.Aeson.Encoding+import Data.ByteString.Builder as B+import qualified Data.IP as IP+import Data.Semigroup (Semigroup, (<>))+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Lazy.Encoding as E+import qualified Data.Text.Read as TR+import Data.Word+import Network.Socket (HostName)+++data TraceID = TraceID+ { traceIdHi :: Maybe Word64+ , traceIdLo :: Word64+ } deriving (Eq, Ord, Show)+++newtype IPv4 = IPv4 { fromIPv4 :: IP.IPv4 }+ deriving (Bounded, Enum, Eq, Ord)++newtype IPv6 = IPv6 { fromIPv6 :: IP.IPv6 }+ deriving (Bounded, Enum, Eq, Ord)++instance Show IPv4 where show = show . fromIPv4+instance Show IPv6 where show = show . fromIPv6++instance Read IPv4 where readsPrec p = map (over _1 IPv4) . readsPrec p+instance Read IPv6 where readsPrec p = map (over _1 IPv6) . readsPrec p++instance ToJSON IPv4 where+ toJSON = toJSON . show . fromIPv4+ toEncoding = string . show . fromIPv4++instance ToJSON IPv6 where+ toJSON = toJSON . show . fromIPv6+ toEncoding = string . show . fromIPv6+++newtype Port = Port { fromPort :: Word16 }+ deriving (Enum, Eq, Num, Ord)++instance Show Port where show = show . fromPort+instance Read Port where readsPrec p = map (over _1 Port) . readsPrec p++instance ToJSON Port where+ toJSON = toJSON . fromPort+ toEncoding = word16 . fromPort+++data Protocol = UDP | HTTP++data Addr a where+ UDPAddr :: HostName -> Port -> Addr 'UDP+ HTTPAddr :: HostName -> Port -> Bool -> Addr 'HTTP++addrHostName :: Lens' (Addr a) HostName+addrHostName f (UDPAddr h p ) = (\h' -> UDPAddr h' p ) <$> f h+addrHostName f (HTTPAddr h p s) = (\h' -> HTTPAddr h' p s) <$> f h++addrPort :: Lens' (Addr a) Port+addrPort f (UDPAddr h p ) = (\p' -> UDPAddr h p' ) <$> f p+addrPort f (HTTPAddr h p s) = (\p' -> HTTPAddr h p' s) <$> f p++addrSecure :: Lens' (Addr 'HTTP) Bool+addrSecure f (HTTPAddr h p s) = (\s' -> HTTPAddr h p s') <$> f s+++newtype Hex = Hex { unHex :: Text }+ deriving (Eq, Show, Monoid, Semigroup)++knownHex :: Text -> Hex+knownHex = Hex++class AsHex a where+ _Hex :: Prism' Hex a++instance AsHex TraceID where+ _Hex = prism' enc dec+ where+ enc (TraceID hi lo)+ = Hex . unHex $ maybe mempty (review _Hex) hi <> review _Hex lo++ dec (Hex t)+ = case Text.splitAt 16 t of+ ("", lo) -> TraceID Nothing <$> preview _Hex (Hex lo)+ (hi, lo) -> TraceID <$> Just (preview _Hex (Hex hi))+ <*> preview _Hex (Hex lo)+ {-# INLINE _Hex #-}++instance AsHex Word64 where+ _Hex = prism' enc dec+ where+ enc = Hex . view strict . E.decodeUtf8 . B.toLazyByteString . B.word64HexFixed+ dec = either (const Nothing) (pure . fst) . TR.hexadecimal . unHex+ {-# INLINE _Hex #-}++hexText :: AsHex a => Getter a Text+hexText = re _Hex . to unHex+{-# INLINE hexText #-}
+ README.md view
@@ -0,0 +1,18 @@+## OpenTracing++The [OpenTracing spec](https://github.com/opentracing/specification/blob/master/specification.md) defines a platform agnostic approach for distributed tracing. Distributed+tracing gives us insights into how complex programs spread across multiple processes are+performing together.++This package provides a core implementation of the OpenTracing spec. It includes+functionality to++ * Create `Span`s describing application code executions, including `Tag`s and+ `LogRecord`s++ * Serialize and deserialize `SpanContext`s across process boundaries++ * Batch and log `FinishedSpan`s++It does not provide any functionality for consuming `Span`s. There are platform specific+backends (CloudTrace, Zipkin, Jaeger, etc) that are provided in other packages.
+ opentracing.cabal view
@@ -0,0 +1,73 @@+cabal-version: 2.2++name: opentracing+version: 0.1.0.0+synopsis: OpenTracing for Haskell+homepage: https://github.com/kim/opentracing+bug-reports: https://github.com/kim/opentracing/issues+author: Kim Altintop+maintainer: Kim Altintop <kim.altintop+opentracing@gmail.com>+copyright: Copyright (c) 2017-2018 Kim Altintop+license: Apache-2.0+license-file: LICENSE+build-type: Simple+extra-source-files:+ CHANGELOG.md+ README.md++source-repository head+ type: git+ location: git@github.com:kim/opentracing.git++library+ exposed-modules:+ OpenTracing+ OpenTracing.Log+ OpenTracing.Propagation+ OpenTracing.Reporting+ OpenTracing.Reporting.Batch+ OpenTracing.Reporting.Pure+ OpenTracing.Reporting.Stdio+ OpenTracing.Sampling+ OpenTracing.Span+ OpenTracing.Standard+ OpenTracing.Tags+ OpenTracing.Time+ OpenTracing.Tracer+ OpenTracing.Types+ other-modules:+ Paths_opentracing+ autogen-modules:+ Paths_opentracing+ ghc-options:+ -Wall+ -funbox-small-strict-fields+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wcompat+ -Wnoncanonical-monad-instances+ build-depends:+ aeson >= 1.1+ , async >= 2.1+ , base >= 4.9 && < 4.16+ , base64-bytestring >= 1.0+ , bytestring >= 0.10+ , case-insensitive >= 1.2+ , clock >= 0.7+ , containers >= 0.5+ , http-types >= 0.9+ , iproute >= 1.7+ , lens >= 4.19+ , mtl >= 2.2+ , mwc-random >= 0.13+ , network >= 2.8+ , safe-exceptions >= 0.1+ , semigroups >= 0.18+ , stm >= 2.4+ , text >= 1.2+ , time >= 1.6+ , transformers >= 0.5+ , unordered-containers >= 0.2+ , uri-bytestring >= 0.2+ , vinyl >= 0.9+ default-language: Haskell2010