{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module OpenTelemetry.Instrumentation.Yesod (
  -- * Middleware functionality
  openTelemetryYesodMiddleware,
  RouteRenderer (..),
  mkRouteToRenderer,
  mkRouteToPattern,

  -- * Utilities
  rheSiteL,
  handlerEnvL,
) where

import qualified Data.HashMap.Strict as H
import Data.List (intercalate)
import Data.Maybe (catMaybes)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Language.Haskell.TH.Syntax
import Lens.Micro
import Network.Wai (requestHeaders)
import qualified OpenTelemetry.Context as Context
import OpenTelemetry.Context.ThreadLocal
import OpenTelemetry.Contrib.SpanTraversals
import OpenTelemetry.Instrumentation.Wai (requestContext)
import OpenTelemetry.Trace.Core hiding (inSpan, inSpan', inSpan'')
import OpenTelemetry.Trace.Monad
import UnliftIO.Exception
import Yesod.Core
import Yesod.Core.Types
import Yesod.Routes.TH.Types


handlerEnvL :: Lens' (HandlerData child site) (RunHandlerEnv child site)
handlerEnvL :: forall child site.
Lens' (HandlerData child site) (RunHandlerEnv child site)
handlerEnvL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall child site.
HandlerData child site -> RunHandlerEnv child site
handlerEnv (\HandlerData child site
h RunHandlerEnv child site
e -> HandlerData child site
h {handlerEnv :: RunHandlerEnv child site
handlerEnv = RunHandlerEnv child site
e})
{-# INLINE handlerEnvL #-}


rheSiteL :: Lens' (RunHandlerEnv child site) site
rheSiteL :: forall child site. Lens' (RunHandlerEnv child site) site
rheSiteL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall child site. RunHandlerEnv child site -> site
rheSite (\RunHandlerEnv child site
rhe site
new -> RunHandlerEnv child site
rhe {rheSite :: site
rheSite = site
new})
{-# INLINE rheSiteL #-}


instance MonadTracer (HandlerFor site) where
  getTracer :: HandlerFor site Tracer
getTracer = do
    TracerProvider
tp <- forall (m :: * -> *). MonadIO m => m TracerProvider
getGlobalTracerProvider
    forall (m :: * -> *).
MonadIO m =>
TracerProvider
-> InstrumentationLibrary -> TracerOptions -> m Tracer
OpenTelemetry.Trace.Core.getTracer TracerProvider
tp InstrumentationLibrary
"hs-opentelemetry-instrumentation-yesod" TracerOptions
tracerOptions


{- | Template Haskell to generate a function named routeToRendererFunction.

 For a route like HomeR, this function returns "HomeR".

 For routes with parents, this function returns e.g. "FooR.BarR.BazR".
-}
mkRouteToRenderer :: Name -> [ResourceTree a] -> Q [Dec]
mkRouteToRenderer :: forall a. Name -> [ResourceTree a] -> Q [Dec]
mkRouteToRenderer Name
appName [ResourceTree a]
ress = do
  let fnName :: Name
fnName = String -> Name
mkName String
"routeToRenderer"
      Type
t1 arrow :: Type -> Type -> Type
`arrow` Type
t2 = Type
ArrowT Type -> Type -> Type
`AppT` Type
t1 Type -> Type -> Type
`AppT` Type
t2

  [[Clause]]
clauses <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a. (Pat -> Pat) -> [String] -> ResourceTree a -> Q [Clause]
goTree forall a. a -> a
id []) [ResourceTree a]
ress

  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    [ Name -> Type -> Dec
SigD Name
fnName ((Name -> Type
ConT ''Route Type -> Type -> Type
`AppT` Name -> Type
ConT Name
appName) Type -> Type -> Type
`arrow` Name -> Type
ConT ''Text)
    , Name -> [Clause] -> Dec
FunD Name
fnName forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Clause]]
clauses
    ]


goTree :: (Pat -> Pat) -> [String] -> ResourceTree a -> Q [Clause]
goTree :: forall a. (Pat -> Pat) -> [String] -> ResourceTree a -> Q [Clause]
goTree Pat -> Pat
front [String]
names (ResourceLeaf Resource a
res) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Pat -> Pat) -> [String] -> Resource a -> Q Clause
goRes Pat -> Pat
front [String]
names Resource a
res
#if MIN_VERSION_template_haskell(2, 18, 0)
goTree Pat -> Pat
front [String]
names (ResourceParent String
name CheckOverlap
_check [Piece a]
pieces [ResourceTree a]
trees) =
  forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a. (Pat -> Pat) -> [String] -> ResourceTree a -> Q [Clause]
goTree Pat -> Pat
front' [String]
newNames) [ResourceTree a]
trees
  where
    ignored :: Pat -> [Pat]
ignored = (forall a. Int -> a -> [a]
replicate Int
toIgnore Pat
WildP forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
    toIgnore :: Int
toIgnore = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. (a -> CheckOverlap) -> [a] -> [a]
filter forall {typ}. Piece typ -> CheckOverlap
isDynamic [Piece a]
pieces
    isDynamic :: Piece typ -> CheckOverlap
isDynamic Dynamic {} = CheckOverlap
True
    isDynamic Static {} = CheckOverlap
False
    front' :: Pat -> Pat
front' = Pat -> Pat
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Type] -> [Pat] -> Pat
ConP (String -> Name
mkName String
name) [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pat -> [Pat]
ignored
    newNames :: [String]
newNames = [String]
names forall a. Semigroup a => a -> a -> a
<> [String
name]
#else
goTree front names (ResourceParent name _check pieces trees) =
  concat <$> mapM (goTree front' newNames) trees
  where
    ignored = (replicate toIgnore WildP ++) . pure
    toIgnore = length $ filter isDynamic pieces
    isDynamic Dynamic {} = True
    isDynamic Static {} = False
    front' = front . ConP (mkName name) . ignored
    newNames = names <> [name]
#endif


goRes :: (Pat -> Pat) -> [String] -> Resource a -> Q Clause
goRes :: forall a. (Pat -> Pat) -> [String] -> Resource a -> Q Clause
goRes Pat -> Pat
front [String]
names Resource {CheckOverlap
String
[String]
[Piece a]
Dispatch a
resourceName :: forall typ. Resource typ -> String
resourcePieces :: forall typ. Resource typ -> [Piece typ]
resourceDispatch :: forall typ. Resource typ -> Dispatch typ
resourceAttrs :: forall typ. Resource typ -> [String]
resourceCheck :: forall typ. Resource typ -> CheckOverlap
resourceCheck :: CheckOverlap
resourceAttrs :: [String]
resourceDispatch :: Dispatch a
resourcePieces :: [Piece a]
resourceName :: String
..} =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    [Pat] -> Body -> [Dec] -> Clause
Clause
      [Pat -> Pat
front forall a b. (a -> b) -> a -> b
$ Name -> [FieldPat] -> Pat
RecP (String -> Name
mkName String
resourceName) []]
      (Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ String -> Exp
toText forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate String
"." ([String]
names forall a. Semigroup a => a -> a -> a
<> [String
resourceName]))
      []
  where
    toText :: String -> Exp
toText String
s = Name -> Exp
VarE 'T.pack Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE (String -> Lit
StringL String
s)


mkRouteToPattern :: Name -> [ResourceTree String] -> Q [Dec]
#if MIN_VERSION_template_haskell(2, 18, 0)
mkRouteToPattern :: Name -> [ResourceTree String] -> Q [Dec]
mkRouteToPattern Name
appName [ResourceTree String]
ress = do
  let fnName :: Name
fnName = String -> Name
mkName String
"routeToPattern"
      Type
t1 arrow :: Type -> Type -> Type
`arrow` Type
t2 = Type
ArrowT Type -> Type -> Type
`AppT` Type
t1 Type -> Type -> Type
`AppT` Type
t2

  [Clause]
clauses <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {f :: * -> *}.
Applicative f =>
FlatResource String -> f Clause
mkClause forall a b. (a -> b) -> a -> b
$ forall a. [ResourceTree a] -> [FlatResource a]
flatten [ResourceTree String]
ress

  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    [ Name -> Type -> Dec
SigD Name
fnName ((Name -> Type
ConT ''Route Type -> Type -> Type
`AppT` Name -> Type
ConT Name
appName) Type -> Type -> Type
`arrow` Name -> Type
ConT ''Text)
    , Name -> [Clause] -> Dec
FunD Name
fnName [Clause]
clauses
    ]

  where
    toText :: String -> Exp
toText String
s = Name -> Exp
VarE 'T.pack Exp -> Exp -> Exp
`AppE` Lit -> Exp
LitE (String -> Lit
StringL String
s)
    isDynamic :: Piece typ -> CheckOverlap
isDynamic Dynamic {} = CheckOverlap
True
    isDynamic Static {} = CheckOverlap
False
    parentPieceWrapper :: (String, [Piece typ]) -> Pat -> Pat
parentPieceWrapper (String
parentName, [Piece typ]
pieces) Pat
nestedPat = Name -> [Type] -> [Pat] -> Pat
ConP (String -> Name
mkName String
parentName) [] forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
      [ forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. (a -> CheckOverlap) -> [a] -> [a]
filter forall {typ}. Piece typ -> CheckOverlap
isDynamic [Piece typ]
pieces) Pat
WildP
      , [Pat
nestedPat]
      ]
    mkClause :: FlatResource String -> f Clause
mkClause fr :: FlatResource String
fr@FlatResource{CheckOverlap
String
[(String, [Piece String])]
[Piece String]
Dispatch String
frParentPieces :: forall a. FlatResource a -> [(String, [Piece a])]
frName :: forall a. FlatResource a -> String
frPieces :: forall a. FlatResource a -> [Piece a]
frDispatch :: forall a. FlatResource a -> Dispatch a
frCheck :: forall a. FlatResource a -> CheckOverlap
frCheck :: CheckOverlap
frDispatch :: Dispatch String
frPieces :: [Piece String]
frName :: String
frParentPieces :: [(String, [Piece String])]
..} = do
      let clausePattern :: Pat
clausePattern = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {typ}. (String, [Piece typ]) -> Pat -> Pat
parentPieceWrapper (Name -> [FieldPat] -> Pat
RecP (String -> Name
mkName String
frName) []) [(String, [Piece String])]
frParentPieces
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause
        [Pat
clausePattern]
        (Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ String -> Exp
toText forall a b. (a -> b) -> a -> b
$ FlatResource String -> String
renderPattern FlatResource String
fr)
        []
#else
mkRouteToPattern appName ress = do
  let fnName = mkName "routeToPattern"
      t1 `arrow` t2 = ArrowT `AppT` t1 `AppT` t2

  clauses <- mapM mkClause $ flatten ress

  pure
    [ SigD fnName ((ConT ''Route `AppT` ConT appName) `arrow` ConT ''Text)
    , FunD fnName clauses
    ]

  where
    toText s = VarE 'T.pack `AppE` LitE (StringL s)
    isDynamic Dynamic {} = True
    isDynamic Static {} = False
    parentPieceWrapper (parentName, pieces) nestedPat = ConP (mkName parentName) $ mconcat
      [ replicate (length $ filter isDynamic pieces) WildP
      , [nestedPat]
      ]
    mkClause fr@FlatResource{..} = do
      let clausePattern = foldr parentPieceWrapper (RecP (mkName frName) []) frParentPieces
      pure $ Clause
        [clausePattern]
        (NormalB $ toText $ renderPattern fr)
        []
#endif


renderPattern :: FlatResource String -> String
renderPattern :: FlatResource String -> String
renderPattern FlatResource {CheckOverlap
String
[(String, [Piece String])]
[Piece String]
Dispatch String
frCheck :: CheckOverlap
frDispatch :: Dispatch String
frPieces :: [Piece String]
frName :: String
frParentPieces :: [(String, [Piece String])]
frParentPieces :: forall a. FlatResource a -> [(String, [Piece a])]
frName :: forall a. FlatResource a -> String
frPieces :: forall a. FlatResource a -> [Piece a]
frDispatch :: forall a. FlatResource a -> Dispatch a
frCheck :: forall a. FlatResource a -> CheckOverlap
..} =
  forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ if CheckOverlap
frCheck then [] else [String
"!"]
      , case [String]
formattedParentPieces forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Piece String -> [String]
routePortionSection [Piece String]
frPieces of
          [] -> [String
"/"]
          [String]
pieces -> [String]
pieces
      , case Dispatch String
frDispatch of
          Methods {[String]
Maybe String
methodsMulti :: forall typ. Dispatch typ -> Maybe typ
methodsMethods :: forall typ. Dispatch typ -> [String]
methodsMethods :: [String]
methodsMulti :: Maybe String
..} ->
            forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
              [ case Maybe String
methodsMulti of
                  Maybe String
Nothing -> []
                  Just String
t -> [String
"/+", String
t]
              ]
          Subsite {} -> []
      ]
  where
    routePortionSection :: Piece String -> [String]
    routePortionSection :: Piece String -> [String]
routePortionSection (Static String
t) = [String
"/", String
t]
    routePortionSection (Dynamic String
t) = [String
"/#{", String
t, String
"}"]

    formattedParentPieces :: [String]
    formattedParentPieces :: [String]
formattedParentPieces = do
      (String
_parentName, [Piece String]
pieces) <- [(String, [Piece String])]
frParentPieces
      Piece String
piece <- [Piece String]
pieces
      Piece String -> [String]
routePortionSection Piece String
piece


data RouteRenderer site = RouteRenderer
  { forall site. RouteRenderer site -> Route site -> Text
nameRender :: Route site -> T.Text
  , forall site. RouteRenderer site -> Route site -> Text
pathRender :: Route site -> T.Text
  }


-- TODO figure out a way to get better code locations for these spans.

-- | This middleware works best when used with `OpenTelemetry.Instrumentation.Wai` middleware.
openTelemetryYesodMiddleware
  :: (ToTypedContent res)
  => RouteRenderer site
  -> HandlerFor site res
  -> HandlerFor site res
openTelemetryYesodMiddleware :: forall res site.
ToTypedContent res =>
RouteRenderer site -> HandlerFor site res -> HandlerFor site res
openTelemetryYesodMiddleware RouteRenderer site
rr HandlerFor site res
m = do
  Request
req <- forall (m :: * -> *). MonadHandler m => m Request
waiRequest
  Maybe (Route site)
mr <- forall (m :: * -> *).
MonadHandler m =>
m (Maybe (Route (HandlerSite m)))
getCurrentRoute
  let mspan :: Maybe Span
mspan = Request -> Maybe Context
requestContext Request
req forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Context -> Maybe Span
Context.lookupSpan
      sharedAttributes :: HashMap Text Attribute
sharedAttributes = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList forall a b. (a -> b) -> a -> b
$
        (Text
"http.framework", forall a. ToAttribute a => a -> Attribute
toAttribute (Text
"yesod" :: Text))
          forall a. a -> [a] -> [a]
: forall a. [Maybe a] -> [a]
catMaybes
            [ do
                Route site
r <- Maybe (Route site)
mr
                forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"http.route", forall a. ToAttribute a => a -> Attribute
toAttribute forall a b. (a -> b) -> a -> b
$ forall site. RouteRenderer site -> Route site -> Text
pathRender RouteRenderer site
rr Route site
r)
            , do
                Route site
r <- Maybe (Route site)
mr
                forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"http.handler", forall a. ToAttribute a => a -> Attribute
toAttribute forall a b. (a -> b) -> a -> b
$ forall site. RouteRenderer site -> Route site -> Text
nameRender RouteRenderer site
rr Route site
r)
            , do
                ByteString
ff <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"X-Forwarded-For" forall a b. (a -> b) -> a -> b
$ Request -> RequestHeaders
requestHeaders Request
req
                forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"http.client_ip", forall a. ToAttribute a => a -> Attribute
toAttribute forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
ff)
            ]
      args :: SpanArguments
args =
        SpanArguments
defaultSpanArguments
          { kind :: SpanKind
kind = forall b a. b -> (a -> b) -> Maybe a -> b
maybe SpanKind
Server (forall a b. a -> b -> a
const SpanKind
Internal) Maybe Span
mspan
          , attributes :: HashMap Text Attribute
attributes = HashMap Text Attribute
sharedAttributes
          }
  case Maybe Span
mspan of
    Maybe Span
Nothing -> do
      Either HandlerContents res
eResult <- forall (m :: * -> *) a.
(MonadUnliftIO m, MonadTracer m, HasCallStack) =>
Text -> SpanArguments -> (Span -> m a) -> m a
inSpan' (forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"notFound" (\Route site
r -> forall site. RouteRenderer site -> Route site -> Text
nameRender RouteRenderer site
rr Route site
r) Maybe (Route site)
mr) SpanArguments
args forall a b. (a -> b) -> a -> b
$ \Span
_s -> do
        forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HandlerFor site res
m) forall a b. (a -> b) -> a -> b
$ \HandlerContents
e -> do
          -- We want to mark the span as an error if it's an InternalError,
          -- the other HCError values are 4xx status codes which don't
          -- really count as a server error in OpenTelemetry spec parlance.
          case HandlerContents
e of
            HCError (InternalError Text
_) -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO HandlerContents
e
            HandlerContents
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left (HandlerContents
e :: HandlerContents))
      case Either HandlerContents res
eResult of
        Left HandlerContents
hc -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO HandlerContents
hc
        Right res
normal -> forall (f :: * -> *) a. Applicative f => a -> f a
pure res
normal
    Just Span
waiSpan -> do
      forall (m :: * -> *).
MonadIO m =>
Span -> HashMap Text Attribute -> m ()
addAttributes Span
waiSpan HashMap Text Attribute
sharedAttributes
      HandlerFor site res
m