hs-opentelemetry-instrumentation-wai (empty) → 0.0.1.0
raw patch · 7 files changed
+230/−0 lines, 7 filesdep +basedep +bytestringdep +hs-opentelemetry-apisetup-changed
Dependencies added: base, bytestring, hs-opentelemetry-api, hs-opentelemetry-instrumentation-wai, http-types, iproute, network, text, vault, wai
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +1/−0
- Setup.hs +2/−0
- hs-opentelemetry-instrumentation-wai.cabal +67/−0
- src/OpenTelemetry/Instrumentation/Wai.hs +125/−0
- test/Spec.hs +2/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for hs-opentelemetry-instrumentation-wai++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Ian Duncan (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Ian Duncan nor the names of other+ 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+OWNER 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.
+ README.md view
@@ -0,0 +1,1 @@+# hs-opentelemetry-instrumentation-wai
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hs-opentelemetry-instrumentation-wai.cabal view
@@ -0,0 +1,67 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name: hs-opentelemetry-instrumentation-wai+version: 0.0.1.0+synopsis: WAI instrumentation middleware for OpenTelemetry+description: Please see the README on GitHub at <https://github.com/iand675/hs-opentelemetry/tree/main/instrumentation/wai#readme>+category: OpenTelemetry, Web+homepage: https://github.com/iand675/hs-opentelemetry#readme+bug-reports: https://github.com/iand675/hs-opentelemetry/issues+author: Ian Duncan+maintainer: ian@iankduncan.com+copyright: 2021 Ian Duncan+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/iand675/hs-opentelemetry++library+ exposed-modules:+ OpenTelemetry.Instrumentation.Wai+ other-modules:+ Paths_hs_opentelemetry_instrumentation_wai+ hs-source-dirs:+ src+ ghc-options: -Wall+ build-depends:+ base >=4.7 && <5+ , bytestring+ , hs-opentelemetry-api+ , http-types+ , iproute+ , network+ , text+ , vault+ , wai+ default-language: Haskell2010++test-suite hs-opentelemetry-instrumentation-wai-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_hs_opentelemetry_instrumentation_wai+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , bytestring+ , hs-opentelemetry-api+ , hs-opentelemetry-instrumentation-wai+ , http-types+ , iproute+ , network+ , text+ , vault+ , wai+ default-language: Haskell2010
+ src/OpenTelemetry/Instrumentation/Wai.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+module OpenTelemetry.Instrumentation.Wai + ( newOpenTelemetryWaiMiddleware+ , newOpenTelemetryWaiMiddleware'+ , requestContext+ ) where++import qualified Data.Vault.Lazy as Vault+import Network.HTTP.Types+import Network.Wai+import qualified OpenTelemetry.Context as Context+import OpenTelemetry.Context.ThreadLocal+import OpenTelemetry.Propagator+import OpenTelemetry.Trace.Core+import System.IO.Unsafe+import qualified Data.Text.Encoding as T+import qualified Data.Text as T+import Control.Monad+import Network.Socket+import Data.IP (fromHostAddress, fromHostAddress6)+import OpenTelemetry.Attributes (lookupAttribute)+import Control.Exception (bracket)++newOpenTelemetryWaiMiddleware :: IO Middleware+newOpenTelemetryWaiMiddleware = getGlobalTracerProvider >>= newOpenTelemetryWaiMiddleware'++newOpenTelemetryWaiMiddleware'+ :: TracerProvider + -> IO Middleware+newOpenTelemetryWaiMiddleware' tp = do+ waiTracer <- getTracer + tp+ "opentelemetry-instrumentation-wai" + (TracerOptions Nothing)+ pure $ middleware waiTracer+ where+ middleware :: Tracer -> Middleware+ middleware tracer app req sendResp = do+ let propagator = getTracerProviderPropagators $ getTracerTracerProvider tracer+ let parentContextM = do+ ctx <- getContext+ ctxt <- extract propagator (requestHeaders req) ctx+ attachContext ctxt+ let path_ = T.decodeUtf8 $ rawPathInfo req+ -- peer = remoteHost req+ bracket + parentContextM+ (\case+ Nothing -> void detachContext+ Just p -> void (attachContext p)+ )+ $ \_ -> do+ inSpan' tracer path_ (defaultSpanArguments { kind = Server }) $ \requestSpan -> do+ ctxt <- getContext+ addAttributes requestSpan+ [ ( "http.method", toAttribute $ T.decodeUtf8 $ requestMethod req)+ -- , ( "http.url",+ -- toAttribute $+ -- T.decodeUtf8+ -- ((if secure req then "https://" else "http://") <> host req <> ":" <> B.pack (show $ port req) <> path req <> queryString req)+ -- )+ , ( "http.target", toAttribute $ T.decodeUtf8 (rawPathInfo req <> rawQueryString req))+ -- , ( "http.host", toAttribute $ T.decodeUtf8 $ host req)+ -- , ( "http.scheme", toAttribute $ TextAttribute $ if secure req then "https" else "http")+ , ( "http.flavor"+ , toAttribute $ case httpVersion req of+ (HttpVersion major minor) -> T.pack (show major <> "." <> show minor)+ )+ , ( "http.user_agent"+ , toAttribute $ maybe "" T.decodeUtf8 (lookup hUserAgent $ requestHeaders req)+ )+ -- TODO HTTP/3 will require detecting this dynamically+ , ( "net.transport", toAttribute ("ip_tcp" :: T.Text))+ ]++ -- TODO this is warp dependent, probably.+ -- , ( "net.host.ip")+ -- , ( "net.host.port")+ -- , ( "net.host.name")+ addAttributes requestSpan $ case remoteHost req of+ SockAddrInet port addr ->+ [ ("net.peer.port", toAttribute (fromIntegral port :: Int))+ , ("net.peer.ip", toAttribute $ T.pack $ show $ fromHostAddress addr)+ ]+ SockAddrInet6 port _ addr _ ->+ [ ("net.peer.port", toAttribute (fromIntegral port :: Int))+ , ("net.peer.ip", toAttribute $ T.pack $ show $ fromHostAddress6 addr)+ ]+ SockAddrUnix path ->+ [ ("net.peer.name", toAttribute $ T.pack path)+ ]+ let req' = req + { vault = Vault.insert + contextKey + ctxt+ (vault req) + }+ app req' $ \resp -> do+ ctxt' <- getContext+ hs <- inject propagator (Context.insertSpan requestSpan ctxt') []+ let resp' = mapResponseHeaders (hs ++) resp+ attrs <- spanGetAttributes requestSpan+ forM_ (lookupAttribute attrs "http.route") $ \case+ AttributeValue (TextAttribute route) -> updateName requestSpan route + _ -> pure ()++ addAttributes requestSpan+ [ ( "http.status_code", toAttribute $ statusCode $ responseStatus resp)+ ]+ when (statusCode (responseStatus resp) >= 500) $ do+ setStatus requestSpan (Error "")+ respReceived <- sendResp resp'+ ts <- getTimestamp+ endSpan requestSpan (Just ts)+ pure respReceived++contextKey :: Vault.Key Context.Context+contextKey = unsafePerformIO Vault.newKey+{-# NOINLINE contextKey #-}++requestContext :: Request -> Maybe Context.Context+requestContext = + Vault.lookup contextKey . + vault
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"