lightstep-haskell 0.2.0 → 0.3.0
raw patch · 9 files changed
+306/−69 lines, 9 filesdep +bytestringdep +http-typesdep +reqdep ~basedep ~http2-clientdep ~http2-client-grpcnew-component:exe:lightstep-haskell-req-examplenew-component:exe:lightstep-haskell-wai-example
Dependencies added: bytestring, http-types, req, wai, warp
Dependency ranges changed: base, http2-client, http2-client-grpc, proto-lens, proto-lens-runtime
Files
- cli/Main.hs +0/−61
- examples/readme/Main.hs +63/−0
- examples/req/Main.hs +34/−0
- examples/wai/Main.hs +34/−0
- lightstep-haskell.cabal +45/−8
- src/LightStep/HighLevel/IO.hs +29/−0
- src/LightStep/LowLevel.hs +1/−0
- src/LightStep/Propagation.hs +68/−0
- src/Network/Wai/Middleware/LightStep.hs +32/−0
− cli/Main.hs
@@ -1,61 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--import Control.Concurrent-import Control.Concurrent.Async-import Data.Maybe-import qualified Data.Text as T-import LightStep.HighLevel.IO (LightStepConfig (..), setTag, withSingletonLightStep, withSpan)-import System.Environment-import System.Exit--seriousBusinessMain :: IO ()-seriousBusinessMain = concurrently_ frontend backend- where- frontend =- withSpan "RESTful API" $ do- threadDelay 10000- setTag "foo" "bar"- withSpan "Kafka" $ do- threadDelay 20000- setTag "foo" "baz"- threadDelay 30000- withSpan "GraphQL" $ do- threadDelay 40000- setTag "foo" "quux"- withSpan "Mongodb" $ do- threadDelay 50000- setTag "lorem" "ipsum"- threadDelay 60000- withSpan "data->json" $ pure ()- withSpan "json->yaml" $ pure ()- withSpan "yaml->xml" $ pure ()- withSpan "xml->protobuf" $ pure ()- withSpan "protobuf->thrift" $ pure ()- withSpan "thrift->base64" $ pure ()- threadDelay 70000- backend =- withSpan "Background Data Science" $ do- threadDelay 10000- withSpan "Tensorflow" $ do- threadDelay 100000- setTag "learning" "deep"- withSpan "Torch" $ do- threadDelay 100000- setTag "learning" "very_deep"- withSpan "Hadoop" $ do- threadDelay 100000- setTag "learning" "super_deep"--main :: IO ()-main = do- token <-- lookupEnv "LIGHTSTEP_TOKEN" >>= \case- Just t -> pure $ T.pack t- Nothing -> do- putStrLn "LIGHTSTEP_TOKEN environment variable not defined"- exitFailure- host <- fromMaybe "ingest.lightstep.com" <$> lookupEnv "LIGHTSTEP_HOST"- port <- maybe 443 read <$> lookupEnv "LIGHTSTEP_PORT"- let lsConfig = LightStepConfig host port token "helloworld" 5- withSingletonLightStep lsConfig seriousBusinessMain- putStrLn "All done"
+ examples/readme/Main.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}++import Control.Concurrent+import Control.Concurrent.Async+import Data.Maybe+import qualified Data.Text as T+import LightStep.HighLevel.IO (LightStepConfig (..), LogEntryKey (..), addLog, setTag, withSingletonLightStep, withSpan)+import System.Environment+import System.Exit++seriousBusinessMain :: IO ()+seriousBusinessMain = concurrently_ frontend backend+ where+ frontend =+ withSpan "RESTful API" $ do+ threadDelay 10000+ setTag "foo" "bar"+ withSpan "Kafka" $ do+ threadDelay 20000+ setTag "foo" "baz"+ threadDelay 30000+ withSpan "GraphQL" $ do+ threadDelay 40000+ setTag "foo" "quux"+ addLog Event "monkey-job"+ addLog (Custom "foo") "bar"+ withSpan "Mongodb" $ do+ threadDelay 50000+ setTag "lorem" "ipsum"+ threadDelay 60000+ withSpan "data->json" $ pure ()+ withSpan "json->yaml" $ pure ()+ withSpan "yaml->xml" $ pure ()+ withSpan "xml->protobuf" $ pure ()+ withSpan "protobuf->thrift" $ pure ()+ withSpan "thrift->base64" $ pure ()+ threadDelay 70000+ backend =+ withSpan "Background Data Science" $ do+ threadDelay 10000+ withSpan "Tensorflow" $ do+ threadDelay 100000+ setTag "learning" "deep"+ withSpan "Torch" $ do+ threadDelay 100000+ setTag "learning" "very_deep"+ withSpan "Hadoop" $ do+ threadDelay 100000+ setTag "learning" "super_deep"++main :: IO ()+main = do+ token <-+ lookupEnv "LIGHTSTEP_TOKEN" >>= \case+ Just t -> pure $ T.pack t+ Nothing -> do+ putStrLn "LIGHTSTEP_TOKEN environment variable not defined"+ exitFailure+ host <- fromMaybe "ingest.lightstep.com" <$> lookupEnv "LIGHTSTEP_HOST"+ port <- maybe 443 read <$> lookupEnv "LIGHTSTEP_PORT"+ let lsConfig = LightStepConfig host port token "helloworld" 5+ withSingletonLightStep lsConfig seriousBusinessMain+ putStrLn "All done"
+ examples/req/Main.hs view
@@ -0,0 +1,34 @@+{-# language OverloadedStrings #-}++import Control.Concurrent+import Data.Maybe+import LightStep.HighLevel.IO+import LightStep.Propagation (headersForSpanContext)+import Network.HTTP.Req+import qualified Data.Text as T+import System.Environment+import System.Exit++clientMain :: IO ()+clientMain = do+ withSpan "req-example" $ do+ setTag "span.kind" "client"+ setTag "component" "http"+ Just ctx <- currentSpanContext+ let opts = port 8736 <> foldMap (\(k, v) -> header k v) (headersForSpanContext ctx)+ url = http "127.0.0.1" /: "test"+ runReq defaultHttpConfig $ req GET url NoReqBody ignoreResponse opts+ threadDelay 1_000_000++main :: IO ()+main = do+ token <-+ lookupEnv "LIGHTSTEP_TOKEN" >>= \case+ Just t -> pure $ T.pack t+ Nothing -> do+ putStrLn "LIGHTSTEP_TOKEN environment variable not defined"+ exitFailure+ host <- fromMaybe "ingest.lightstep.com" <$> lookupEnv "LIGHTSTEP_HOST"+ lsport <- maybe 443 read <$> lookupEnv "LIGHTSTEP_PORT"+ let lsConfig = LightStepConfig host lsport token "example-req-client" 5+ withSingletonLightStep lsConfig clientMain
+ examples/wai/Main.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE OverloadedStrings #-}++import Data.Maybe (fromMaybe)+import System.Environment+import System.Exit+import LightStep.HighLevel.IO (LightStepConfig (..), withSingletonLightStep)+import Network.Wai.Middleware.LightStep+import Network.Wai+import Network.HTTP.Types+import Network.Wai.Handler.Warp (run)+import qualified Data.Text as T++robustScalableProductionReadyMicroservice :: Application+robustScalableProductionReadyMicroservice = \_req respond -> do+ putStrLn "Disrupting the industry"+ respond $ responseLBS+ status200+ [("Content-Type", "text/plain")]+ "It's all data!"++main :: IO ()+main = do+ token <-+ lookupEnv "LIGHTSTEP_TOKEN" >>= \case+ Just t -> pure $ T.pack t+ Nothing -> do+ putStrLn "LIGHTSTEP_TOKEN environment variable not defined"+ exitFailure+ host <- fromMaybe "ingest.lightstep.com" <$> lookupEnv "LIGHTSTEP_HOST"+ port <- maybe 443 read <$> lookupEnv "LIGHTSTEP_PORT"+ let lsConfig = LightStepConfig host port token "example-wai-service" 5+ microserviceWithTracing = tracingMiddleware robustScalableProductionReadyMicroservice+ withSingletonLightStep lsConfig $+ run 8736 microserviceWithTracing
lightstep-haskell.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.4 name: lightstep-haskell-version: 0.2.0+version: 0.3.0 synopsis: LightStep OpenTracing client library description: LightStep OpenTracing client library. Uses GRPC transport via proto-lens. category: Tools@@ -31,6 +31,7 @@ ScopedTypeVariables TupleSections TypeApplications+ ViewPatterns ghc-options: -Wall -Wcompat@@ -50,6 +51,8 @@ LightStep.LowLevel LightStep.HighLevel.IO LightStep.Internal.Debug+ LightStep.Propagation+ Network.Wai.Middleware.LightStep other-modules: Paths_lightstep_haskell Proto.Collector@@ -66,19 +69,22 @@ build-depends: base >=4.12 && <5 , async+ , bytestring , chronos , containers , safe-exceptions- , http2-client- , http2-client-grpc+ , http2-client >= 0.9.0.0+ , http2-client-grpc >= 0.7.0.0 , lens , mtl- , proto-lens- , proto-lens-runtime+ , proto-lens >= 0.5.1.0+ , proto-lens-runtime >= 0.5.0.0 , stm , text , transformers , unordered-containers+ , http-types+ , wai executable lightstep-haskell-example import: options@@ -87,13 +93,44 @@ -rtsopts -with-rtsopts=-N main-is: Main.hs- other-modules:- Paths_lightstep_haskell hs-source-dirs:- cli+ examples/readme build-depends: base >=4.9 && <5 , async , http2-client , lightstep-haskell , text++executable lightstep-haskell-wai-example+ import: options+ ghc-options:+ -threaded+ -rtsopts+ -with-rtsopts=-N+ main-is: Main.hs+ hs-source-dirs:+ examples/wai+ build-depends:+ base >=4.9 && <5+ , lightstep-haskell+ , http-types+ , text+ , wai+ , warp++executable lightstep-haskell-req-example+ import: options+ ghc-options:+ -threaded+ -rtsopts+ -with-rtsopts=-N+ main-is: Main.hs+ hs-source-dirs:+ examples/req+ build-depends:+ base >=4.9 && <5+ , lightstep-haskell+ , http-types+ , text+ , req >= 3.0.0
src/LightStep/HighLevel/IO.hs view
@@ -28,6 +28,15 @@ globalSharedMutableSpanStacks :: MVar (HM.HashMap ThreadId [Span]) globalSharedMutableSpanStacks = unsafePerformIO (newMVar mempty) +data LogEntryKey = ErrorKind | Event | Message | Stack | Custom T.Text++showLogEntryKey :: LogEntryKey -> T.Text+showLogEntryKey ErrorKind = T.pack "error.kind"+showLogEntryKey Event = T.pack "event"+showLogEntryKey Message = T.pack "message"+showLogEntryKey Stack = T.pack "stack"+showLogEntryKey (Custom x) = x+ withSpan :: MonadIO m => MonadMask m => T.Text -> m a -> m a withSpan opName action = bracket@@ -75,9 +84,29 @@ in pure stacks' ) +currentSpanContext :: MonadIO m => m (Maybe SpanContext)+currentSpanContext = liftIO $ do+ tId <- myThreadId+ stacks <- readMVar globalSharedMutableSpanStacks+ let ctx =+ case stacks HM.! tId of+ (sp : _) -> Just $ sp ^. spanContext+ _ -> Nothing+ pure ctx+ + setTag :: MonadIO m => T.Text -> T.Text -> m () setTag k v = modifyCurrentSpan (tags %~ (<> [defMessage & key .~ k & stringValue .~ v]))++addLog :: LogEntryKey -> T.Text -> IO ()+addLog k v =+ modifyCurrentSpan (logs %~ (<> [defMessage & fields .~ [defMessage & key .~ showLogEntryKey k & stringValue .~ v]]))++setParentSpanContext :: MonadIO m => SpanContext -> m ()+setParentSpanContext ctx = modifyCurrentSpan $ \sp -> sp+ & references .~ [defMessage & relationship .~ Reference'CHILD_OF & spanContext .~ ctx]+ & spanContext . traceId .~ (ctx ^. traceId) {-# NOINLINE globalSharedMutableSingletonState #-} globalSharedMutableSingletonState :: TBQueue Span
src/LightStep/LowLevel.hs view
@@ -116,6 +116,7 @@ startSpan :: T.Text -> IO Span startSpan op = do nanosSinceEpoch <- getTime <$> now+ -- FIXME: make those ids randomer let sid = fromIntegral nanosSinceEpoch tid = fromIntegral nanosSinceEpoch pure $
+ src/LightStep/Propagation.hs view
@@ -0,0 +1,68 @@+{-# language OverloadedStrings #-}++module LightStep.Propagation where++import Data.Bits+import Control.Lens+import Data.List (foldl')+import qualified Data.ByteString as BS+import Data.ProtoLens.Message (defMessage)+import Network.HTTP.Types+import Network.Wai+import Proto.Collector+import Proto.Collector_Fields+import GHC.Word++extractSpanContextFromRequest :: Request -> Maybe SpanContext+extractSpanContextFromRequest = extractSpanContextFromRequestHeaders . requestHeaders++extractSpanContextFromRequestHeaders :: RequestHeaders -> Maybe SpanContext+extractSpanContextFromRequestHeaders hdrs =+ case foldl' go (Nothing, Nothing) hdrs of+ (Just tid, Just sid) -> defMessage+ & traceId .~ tid+ & spanId .~ sid+ & Just+ _ -> Nothing+ where+ -- TODO: Zipkin style propagation++ go (_, sid) ("ot-tracer-traceid", decode_u64 -> Just tid) = (Just tid, sid)+ go (tid, _) ("ot-tracer-spanid", decode_u64 -> Just sid) = (tid, Just sid)++ -- TODO: Propagation of the whole span context in a single header+ -- go _ ("x-ot-span-context", parse128 -> Just (tid, sid)) = (Just tid, Just sid)++ go acc _ = acc+++ -- parse128 :: BS.ByteString -> Maybe (Word64, Word64)+ -- parse128 _ = Nothing -- TODO++headersForSpanContext :: SpanContext -> [(BS.ByteString, BS.ByteString)]+headersForSpanContext ctx =+ [ ("ot-tracer-traceid", encode_u64 $ ctx ^. traceId)+ , ("ot-tracer-spanid", encode_u64 $ ctx ^. spanId)+ ]++encode_u64 :: Word64 -> BS.ByteString+-- TODO: a better way to encode base16+encode_u64 x =+ let encodeChar :: Word8 -> Word8+ encodeChar c | c < 10 = 48 + c+ encodeChar c = 87 + c+ hexDigits = go 16 [] x+ go :: Int -> [Word8] -> Word64 -> [Word8]+ go 0 acc _ = acc+ go n acc v = go (n - 1) (encodeChar (fromIntegral v .&. 0x0f) : acc) (v `div` 16)+ in BS.pack hexDigits++decode_u64 :: BS.ByteString -> Maybe Word64+decode_u64 bytes | BS.length bytes /= 16 = Nothing+decode_u64 bytes = BS.foldl' go (Just 0) bytes+ where+ go Nothing _ = Nothing+ go (Just !result) d | d >= 48 && d < 58 = Just $ result * 16 + fromIntegral d - 48+ go (Just result) d | d >= 97 && d < 124 = Just $ result * 16 + fromIntegral d - 87+ go _ _ = Nothing+
+ src/Network/Wai/Middleware/LightStep.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Middleware.LightStep where++import qualified Data.Text as T+import LightStep.HighLevel.IO+import qualified Data.Text.Encoding as T+import LightStep.Propagation+import Network.Wai+import Network.HTTP.Types++-- Semantic conventions for HTTP spans:+-- https://github.com/open-telemetry/opentelemetry-specification/blob/master/specification/data-http.md++tracingMiddleware :: Application -> Application+tracingMiddleware app = \req sendResp -> do+ withSpan "WAI handler" $ do+ case extractSpanContextFromRequest req of+ Just ctx -> do+ setParentSpanContext ctx+ _ -> pure ()+ setTag "span.kind" "server"+ setTag "component" "http"+ setTag "http.method" $ T.decodeUtf8 (requestMethod req)+ setTag "http.target" $ T.decodeUtf8 (rawPathInfo req)+ setTag "http.flavor" $ showT (httpVersion req)+ app req $ \resp -> do+ setTag "http.status_code" $ showT (statusCode $ responseStatus resp)+ sendResp resp++showT :: Show a => a -> T.Text+showT = T.pack . show