diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright 2018 Symbiont.io + +Redistribution and use in source and binary forms, with or without modification, +are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors + may be used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/exe/Main.hs b/exe/Main.hs new file mode 100644 --- /dev/null +++ b/exe/Main.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TupleSections #-} + +import Control.Applicative ((<|>)) +import Data.Aeson (FromJSON, eitherDecodeStrict, parseJSON, + withObject, (.:)) +import qualified Data.ByteString as BS +import Data.Foldable (traverse_) +import Data.List (intersect, nub, (\\)) +import Data.List.Extra (groupSort) +import Data.List.NonEmpty (NonEmpty ((:|)), toList) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (maybeToList) +import Data.Text (Text, intercalate, map, pack) +import Data.Text.IO (putStrLn) +import GHC.Generics (Generic) +import Interval (Interval, interval, measure, width) +import qualified Options.Applicative as Opts +import Prelude hiding (map, putStrLn) + +main :: IO () +main = do + Options{..} <- Opts.execParser $ + Opts.info (Opts.helper <*> optionsParser) Opts.fullDesc + text <- case input of + FileInput file -> BS.readFile file + StdInput -> BS.getContents + Jaeger dat <- either fail pure $ eitherDecodeStrict text + let stacks = buildStacks ignoreTags annotated =<< (buildFlames . buildLookup $ dat) + traverse_ (putStrLn . drawStack) stacks + +data Options = Options + { input :: Input + , ignoreTags :: [Tag] + , annotated :: [ProcessID] + } +data Input = FileInput FilePath | StdInput +optionsParser :: Opts.Parser Options +optionsParser = Options + <$> (file <|> pure StdInput) + <*> Opts.many tag + <*> Opts.many ann + where + file = FileInput <$> Opts.strOption + ( Opts.long "file" + <> Opts.short 'f' + <> Opts.metavar "FILENAME" + <> Opts.help "Input file") + tag = Tag <$> Opts.strOption + ( Opts.short 'i' + <> Opts.long "ignore" + <> Opts.metavar "TAG-KEY" + <> Opts.help "Ignore spans with this tag key") + ann = ProcessID <$> Opts.strOption + ( Opts.short 'a' + <> Opts.long "annotated" + <> Opts.metavar "ANN" + <> Opts.help "Annotate this process when using the `chain` palette") + +newtype Jaeger = Jaeger [Data] +instance FromJSON Jaeger where + parseJSON = withObject "Jaeger" $ \v -> Jaeger <$> v .: "data" + +newtype TraceID = TraceID Text deriving newtype (Eq, Ord, FromJSON) +newtype SpanID = SpanID Text deriving newtype (Eq, Ord, FromJSON) +newtype ProcessID = ProcessID Text deriving newtype (Eq, FromJSON) +newtype Name = Name { unName :: Text } deriving newtype (Eq, FromJSON) + +data Data = Data + { traceID :: TraceID + , spans :: [Span] + } deriving (Generic, FromJSON) + +data Span = Span + { spanID :: SpanID + , operationName :: Name + , references :: [Reference] + , startTime :: Integer + , duration :: Integer + , tags :: [Tag] + , processID :: ProcessID + } deriving (Generic, FromJSON) + +data Reference = Reference + { traceID :: TraceID + , spanID :: SpanID + } deriving (Eq, Ord, Generic, FromJSON) + +newtype Tag = Tag + { key :: Text + } deriving (Eq, Generic) + deriving anyclass (FromJSON) + +type Lookup = [(Reference, Span)] + +buildLookup :: [Data] -> Lookup +buildLookup dat = do (Data t ss) <- dat + do s @ Span{..} <- ss + pure (Reference t spanID, s) + +data Flame = Flame + { time :: Interval + , name :: Name + , process :: ProcessID + , children :: [Flame] + , tags :: [Tag] + } + +selftime :: Flame -> Integer +selftime f = max 0 $ (width $ time f) - (measure $ time <$> children f) + +-- We only support one parent per span. +-- +-- https://github.com/opentracing/opentracing.io/issues/28 +-- +-- With multiple parents, a parent span can end at a point in time before a +-- child span. For example, in the case of doing a write which later triggers a +-- flush, the write might finish long before the flush even starts. This makes +-- it impossible to treat spans as a flame graph or traditional stack trace, +-- like you can in a single-parent world. This may make writing a GUI harder +-- since you can't do certain flame-graph-like visualizations. +buildFlames :: Lookup -> [Flame] +buildFlames ss = build <$> (maybeToList . lookupSpan =<< (nub $ roots ++ orphans)) + where + roots :: [Reference] + roots = fst <$> filter (\ (_, Span{..}) -> null references) ss + orphans :: [Reference] + orphans = do absent <- (Map.keys children) \\ (Map.keys spans) + concat $ maybeToList $ Map.lookup absent children + spans :: Map Reference Span + spans = Map.fromList ss + children :: Map Reference [Reference] + children = Map.fromList $ groupSort $ do (i, Span{..}) <- ss + (, i) <$> references + lookupSpan :: Reference -> Maybe (Reference, Span) + lookupSpan ref = (ref,) <$> (Map.lookup ref spans) + build (i, Span{..}) = Flame (interval startTime (startTime + duration)) + operationName + processID + (build <$> deps i) + tags + deps i = do refs <- maybeToList $ Map.lookup i children + ref <- refs + maybeToList $ lookupSpan ref + +-- https://github.com/brendangregg/FlameGraph/blob/master/flamegraph.pl +-- +-- The input is stack frames and sample counts formatted as single lines. Each +-- frame in the stack is semicolon separated, with a space and count at the end +-- of the line. Example input: +-- +-- swapper;start_kernel;rest_init;cpu_idle;default_idle;native_safe_halt 1 +-- +-- The input functions can optionally have annotations at the end of each +-- function name, following a precedent by some tools (Linux perf's _[k]): +-- +-- _[k] for kernel +-- _[i] for inlined +-- _[j] for jit +-- _[w] for waker +-- +-- They are used merely for colors by some palettes, eg, flamegraph.pl +-- --color=java. + +data Stack = Stack + { frames :: NonEmpty Name -- children (head) followed by parents (tail) + , samples :: Integer + , annotated :: Bool + } + +buildStacks :: [Tag] -> [ProcessID] -> Flame -> [Stack] +buildStacks banned annotate = stacks [] + where + stacks :: [Name] -> Flame -> [Stack] + stacks parents f @ Flame{..} = + if not . null $ intersect banned tags + then [] + else Stack (name :| parents) (selftime f) (elem process annotate) : + (stacks (name : parents) =<< children) + +drawStack :: Stack -> Text +drawStack Stack{..} = intercalate ";" (map cleanup . unName <$> + (reverse . toList $ frames)) + <> ann <> " " <> (pack . show $ samples) + where cleanup ' ' = '.' + cleanup ';' = '.' + cleanup '[' = '.' + cleanup ']' = '.' + cleanup c = c + ann = pack $ if annotated then "_[w]" else "" diff --git a/jaeger-flamegraph.cabal b/jaeger-flamegraph.cabal new file mode 100644 --- /dev/null +++ b/jaeger-flamegraph.cabal @@ -0,0 +1,70 @@ +cabal-version: 2.2 +name: jaeger-flamegraph +version: 1.0.0 +synopsis: Generate flamegraphs from Jaeger .json dumps. +license: BSD-3-Clause +license-file: LICENSE +author: Sam Halliday +maintainer: Sam Halliday +copyright: (c) 2018 Symbiont.io +bug-reports: https://github.com/symbiont-io/jaeger-flamegraph/pulls +tested-with: GHC ^>= 8.4.4 || ^>= 8.6.2 +category: Testing +description: + This is a small tool to convert JSON dumps obtained from a Jaeger + server () into a format consumable + by [FlameGraph](https://github.com/brendangregg/FlameGraph). + . + First download the traces for your SERVICE limiting to LIMIT traces + . + > $ curl http://your-jaeger-installation/api/traces?service=SERVICE&limit=LIMIT > input.json + . + using the [undocumented Jaeger API](https://github.com/jaegertracing/jaeger/issues/456#issuecomment-412560321) + then use @jaeger-flamegraph@ to convert the data and send to @flamegraph.pl@ + . + > $ jaeger-flamegraph -f input.json | flamegraph.pl > output.svg + . + +source-repository head + type: git + location: https://github.com/symbiont-io/jaeger-flamegraph + +-- https://www.haskell.org/cabal/users-guide/cabal-projectindex.html + +common deps + build-depends: , base ^>= 4.11.1.0 || ^>= 4.12.0.0 + ghc-options: -Wall + -Werror=missing-home-modules + default-language: Haskell2010 + +executable jaeger-flamegraph + import: deps + hs-source-dirs: exe + main-is: Main.hs + build-depends: , jaeger-flamegraph + , bytestring ^>= 0.10.8.2 + , containers ^>= 0.6.0.1 + , extra ^>= 1.6.13 + , aeson ^>= 1.4.1.0 + , optparse-applicative ^>= 0.14.3.0 + , text ^>= 1.2.3.1 + ghc-options: -threaded + +library + import: deps + hs-source-dirs: library + exposed-modules: Interval + build-depends: , QuickCheck ^>= 2.12.6.1 + +test-suite tests + import: deps + hs-source-dirs: test + type: exitcode-stdio-1.0 + main-is: Driver.hs + other-modules: IntervalTest + build-depends: , jaeger-flamegraph + , tasty ^>= 1.1.0.4 + , tasty-hspec ^>= 1.1.5 + , tasty-quickcheck ^>= 0.10 + build-tool-depends: tasty-discover:tasty-discover ^>= 4.2.1 + ghc-options: -threaded diff --git a/library/Interval.hs b/library/Interval.hs new file mode 100644 --- /dev/null +++ b/library/Interval.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Interval + ( Interval + , interval + , measure + , width) +where + +import Data.List (sort) +import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) + +-- nothing on http://hackage.haskell.org/packages/search?terms=interval +data Interval = Interval Integer Integer -- ^ assume from <= to + deriving (Eq, Ord, Show) + +interval :: Integer -> Integer -> Interval +interval a b | a <= b = Interval a b + | otherwise = Interval b a + +width :: Interval -> Integer +width (Interval from to) = to - from + +-- idea by etorreborre +measure :: [Interval] -> Integer +measure unsorted = + count $ sieve sorted + where + sorted = sort unsorted + sieve (car@(Interval a b) : cadr@(Interval c d) : rest) = + if a == c || c <= b + then sieve $ Interval a (max b d) : rest + else car : sieve (cadr : rest) + sieve done = done + count is = sum $ width <$> is + +instance Arbitrary Interval where + arbitrary = do a <- arbitrary + b <- arbitrary + pure $ interval a b diff --git a/test/Driver.hs b/test/Driver.hs new file mode 100644 --- /dev/null +++ b/test/Driver.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover #-} diff --git a/test/IntervalTest.hs b/test/IntervalTest.hs new file mode 100644 --- /dev/null +++ b/test/IntervalTest.hs @@ -0,0 +1,32 @@ +module IntervalTest where + +import Data.List (nub, permutations) +import Interval +import Test.Tasty.Hspec + +-- https://hspec.github.io/writing-specs.html +-- https://hackage.haskell.org/package/tasty-discover + +spec_interval :: Spec +spec_interval = do + describe "measure" $ do + it "should support one interval" $ do + (measure [interval 10 12]) `shouldBe` 2 + + it "should support disjoint intervals" $ do + (measure [(interval 10 12), (interval 20 25)]) `shouldBe` 7 + + it "should support a more complex interval" $ do + (measure [ (interval 10 12) + , (interval 20 25) + , (interval 10 25) + , (interval 21 22) + ]) `shouldBe` 15 + +prop_lte :: [Interval] -> Bool +prop_lte is = (measure is) <= (sum $ width <$> is) + +-- permutations is too slow, so trim the list +prop_permutations :: [Interval] -> Bool +prop_permutations is = + 1 == (length $ nub $ measure <$> (permutations . take 7 $ is))