diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +* 0.1.0.0 (2012-04-20) + +After years of friendly reminders, a zero version gets finally released =] diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/OpenTracing.hs b/OpenTracing.hs new file mode 100644 --- /dev/null +++ b/OpenTracing.hs @@ -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 diff --git a/OpenTracing/Log.hs b/OpenTracing/Log.hs new file mode 100644 --- /dev/null +++ b/OpenTracing/Log.hs @@ -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 diff --git a/OpenTracing/Propagation.hs b/OpenTracing/Propagation.hs new file mode 100644 --- /dev/null +++ b/OpenTracing/Propagation.hs @@ -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)) diff --git a/OpenTracing/Reporting.hs b/OpenTracing/Reporting.hs new file mode 100644 --- /dev/null +++ b/OpenTracing/Reporting.hs @@ -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 diff --git a/OpenTracing/Reporting/Batch.hs b/OpenTracing/Reporting/Batch.hs new file mode 100644 --- /dev/null +++ b/OpenTracing/Reporting/Batch.hs @@ -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' diff --git a/OpenTracing/Reporting/Pure.hs b/OpenTracing/Reporting/Pure.hs new file mode 100644 --- /dev/null +++ b/OpenTracing/Reporting/Pure.hs @@ -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 $ (,) [] diff --git a/OpenTracing/Reporting/Stdio.hs b/OpenTracing/Reporting/Stdio.hs new file mode 100644 --- /dev/null +++ b/OpenTracing/Reporting/Stdio.hs @@ -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 diff --git a/OpenTracing/Sampling.hs b/OpenTracing/Sampling.hs new file mode 100644 --- /dev/null +++ b/OpenTracing/Sampling.hs @@ -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) diff --git a/OpenTracing/Span.hs b/OpenTracing/Span.hs new file mode 100644 --- /dev/null +++ b/OpenTracing/Span.hs @@ -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 diff --git a/OpenTracing/Standard.hs b/OpenTracing/Standard.hs new file mode 100644 --- /dev/null +++ b/OpenTracing/Standard.hs @@ -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 + } diff --git a/OpenTracing/Tags.hs b/OpenTracing/Tags.hs new file mode 100644 --- /dev/null +++ b/OpenTracing/Tags.hs @@ -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 diff --git a/OpenTracing/Time.hs b/OpenTracing/Time.hs new file mode 100644 --- /dev/null +++ b/OpenTracing/Time.hs @@ -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 #-} diff --git a/OpenTracing/Tracer.hs b/OpenTracing/Tracer.hs new file mode 100644 --- /dev/null +++ b/OpenTracing/Tracer.hs @@ -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 diff --git a/OpenTracing/Types.hs b/OpenTracing/Types.hs new file mode 100644 --- /dev/null +++ b/OpenTracing/Types.hs @@ -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 #-} diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/opentracing.cabal b/opentracing.cabal new file mode 100644 --- /dev/null +++ b/opentracing.cabal @@ -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 +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