{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module OpenTelemetry.Instrumentation.Yesod
  (
  -- * Middleware functionality
  openTelemetryYesodMiddleware,
  RouteRenderer(..),
  mkRouteToRenderer,
  mkRouteToPattern,
  -- * Utilities
  rheSiteL,
  handlerEnvL
  ) where

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

handlerEnvL :: Lens' (HandlerData child site) (RunHandlerEnv child site)
handlerEnvL :: (RunHandlerEnv child site -> f (RunHandlerEnv child site))
-> HandlerData child site -> f (HandlerData child site)
handlerEnvL = (HandlerData child site -> RunHandlerEnv child site)
-> (HandlerData child site
    -> RunHandlerEnv child site -> HandlerData child site)
-> Lens
     (HandlerData child site)
     (HandlerData child site)
     (RunHandlerEnv child site)
     (RunHandlerEnv child site)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens HandlerData child site -> RunHandlerEnv child site
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 :: (site -> f site)
-> RunHandlerEnv child site -> f (RunHandlerEnv child site)
rheSiteL = (RunHandlerEnv child site -> site)
-> (RunHandlerEnv child site -> site -> RunHandlerEnv child site)
-> Lens
     (RunHandlerEnv child site) (RunHandlerEnv child site) site site
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens RunHandlerEnv child site -> site
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 <- HandlerFor site TracerProvider
forall (m :: * -> *). MonadIO m => m TracerProvider
getGlobalTracerProvider
    TracerProvider
-> InstrumentationLibrary
-> TracerOptions
-> HandlerFor site Tracer
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 :: 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 <- (ResourceTree a -> Q [Clause]) -> [ResourceTree a] -> Q [[Clause]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Pat -> Pat) -> [String] -> ResourceTree a -> Q [Clause]
forall a. (Pat -> Pat) -> [String] -> ResourceTree a -> Q [Clause]
goTree Pat -> Pat
forall a. a -> a
id []) [ResourceTree a]
ress

  [Dec] -> Q [Dec]
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] -> Dec) -> [Clause] -> Dec
forall a b. (a -> b) -> a -> b
$ [[Clause]] -> [Clause]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Clause]]
clauses
    ]

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

goRes :: (Pat -> Pat) -> [String] -> Resource a -> Q Clause
goRes :: (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
..} =
  Clause -> Q Clause
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$
    [Pat] -> Body -> [Dec] -> Clause
Clause
      [Pat -> Pat
front (Pat -> Pat) -> Pat -> Pat
forall a b. (a -> b) -> a -> b
$ Name -> [FieldPat] -> Pat
RecP (String -> Name
mkName String
resourceName) []]
      (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ String -> Exp
toText (String -> Exp) -> String -> Exp
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." ([String]
names [String] -> [String] -> [String]
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]
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 <- (FlatResource String -> Q Clause)
-> [FlatResource String] -> Q [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FlatResource String -> Q Clause
forall (f :: * -> *).
Applicative f =>
FlatResource String -> f Clause
mkClause ([FlatResource String] -> Q [Clause])
-> [FlatResource String] -> Q [Clause]
forall a b. (a -> b) -> a -> b
$ [ResourceTree String] -> [FlatResource String]
forall a. [ResourceTree a] -> [FlatResource a]
flatten [ResourceTree String]
ress

  [Dec] -> Q [Dec]
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
#if MIN_VERSION_template_haskell(2, 18, 0)
    parentPieceWrapper (parentName, pieces) nestedPat = ConP (mkName parentName) [] $ mconcat
#else
    parentPieceWrapper :: (String, [Piece typ]) -> Pat -> Pat
parentPieceWrapper (String
parentName, [Piece typ]
pieces) Pat
nestedPat = Name -> [Pat] -> Pat
ConP (String -> Name
mkName String
parentName) ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ [[Pat]] -> [Pat]
forall a. Monoid a => [a] -> a
mconcat
#endif
      [ Int -> Pat -> [Pat]
forall a. Int -> a -> [a]
replicate ([Piece typ] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Piece typ] -> Int) -> [Piece typ] -> Int
forall a b. (a -> b) -> a -> b
$ (Piece typ -> CheckOverlap) -> [Piece typ] -> [Piece typ]
forall a. (a -> CheckOverlap) -> [a] -> [a]
filter Piece typ -> CheckOverlap
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 = ((String, [Piece String]) -> Pat -> Pat)
-> Pat -> [(String, [Piece String])] -> Pat
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (String, [Piece String]) -> Pat -> Pat
forall typ. (String, [Piece typ]) -> Pat -> Pat
parentPieceWrapper (Name -> [FieldPat] -> Pat
RecP (String -> Name
mkName String
frName) []) [(String, [Piece String])]
frParentPieces
      Clause -> f Clause
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Clause -> f Clause) -> Clause -> f Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause
        [Pat
clausePattern]
        (Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ String -> Exp
toText (String -> Exp) -> String -> Exp
forall a b. (a -> b) -> a -> b
$ FlatResource String -> String
renderPattern FlatResource String
fr)
        []

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
..} = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ if CheckOverlap
frCheck then [] else [String
"!"]
  , case [String]
formattedParentPieces [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> (Piece String -> [String]) -> [Piece String] -> [String]
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
..} -> [[String]] -> [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
  { RouteRenderer site -> Route site -> Text
nameRender :: Route site -> T.Text
  , RouteRenderer site -> Route site -> Text
pathRender :: Route site -> T.Text
  }

openTelemetryYesodMiddleware
  :: (ToTypedContent res)
  => RouteRenderer site
  -> HandlerFor site res
  -> HandlerFor site res
openTelemetryYesodMiddleware :: RouteRenderer site -> HandlerFor site res -> HandlerFor site res
openTelemetryYesodMiddleware RouteRenderer site
rr HandlerFor site res
m = do
  -- tracer <- OpenTelemetry.Trace.Monad.getTracer
  Request
req <- HandlerFor site Request
forall (m :: * -> *). MonadHandler m => m Request
waiRequest
  Maybe Span
mspan <- Context -> Maybe Span
Context.lookupSpan (Context -> Maybe Span)
-> HandlerFor site Context -> HandlerFor site (Maybe Span)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HandlerFor site Context
forall (m :: * -> *). MonadIO m => m Context
getContext
  Maybe (Route site)
mr <- HandlerFor site (Maybe (Route site))
forall (m :: * -> *).
MonadHandler m =>
m (Maybe (Route (HandlerSite m)))
getCurrentRoute
  let sharedAttributes :: [(Text, Attribute)]
sharedAttributes = [Maybe (Text, Attribute)] -> [(Text, Attribute)]
forall a. [Maybe a] -> [a]
catMaybes
        [ do
            Route site
r <- Maybe (Route site)
mr
            (Text, Attribute) -> Maybe (Text, Attribute)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"http.route", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ RouteRenderer site -> Route site -> Text
forall site. RouteRenderer site -> Route site -> Text
pathRender RouteRenderer site
rr Route site
r)
        , do
            ByteString
ff <- HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"X-Forwarded-For" ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
requestHeaders Request
req
            (Text, Attribute) -> Maybe (Text, Attribute)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"http.client_ip", Text -> Attribute
forall a. ToAttribute a => a -> Attribute
toAttribute (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
ff)
        ]
      args :: SpanArguments
args = SpanArguments
defaultSpanArguments
        { kind :: SpanKind
kind = SpanKind -> (Span -> SpanKind) -> Maybe Span -> SpanKind
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SpanKind
Server (SpanKind -> Span -> SpanKind
forall a b. a -> b -> a
const SpanKind
Internal) Maybe Span
mspan
        , attributes :: [(Text, Attribute)]
attributes = [(Text, Attribute)]
sharedAttributes
        }
  (Span -> HandlerFor site ()) -> Maybe Span -> HandlerFor site ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Span -> [(Text, Attribute)] -> HandlerFor site ()
forall (m :: * -> *).
MonadIO m =>
Span -> [(Text, Attribute)] -> m ()
`addAttributes` [(Text, Attribute)]
sharedAttributes) Maybe Span
mspan
  Either HandlerContents res
eResult <- Text
-> SpanArguments
-> (Span -> HandlerFor site (Either HandlerContents res))
-> HandlerFor site (Either HandlerContents res)
forall (m :: * -> *) a.
(MonadUnliftIO m, MonadTracer m, HasCallStack) =>
Text -> SpanArguments -> (Span -> m a) -> m a
inSpan' (Text -> (Route site -> Text) -> Maybe (Route site) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"yesod.handler.notFound" (\Route site
r -> Text
"yesod.handler." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RouteRenderer site -> Route site -> Text
forall site. RouteRenderer site -> Route site -> Text
nameRender RouteRenderer site
rr Route site
r) Maybe (Route site)
mr) SpanArguments
args ((Span -> HandlerFor site (Either HandlerContents res))
 -> HandlerFor site (Either HandlerContents res))
-> (Span -> HandlerFor site (Either HandlerContents res))
-> HandlerFor site (Either HandlerContents res)
forall a b. (a -> b) -> a -> b
$ \Span
_s -> do
    HandlerFor site (Either HandlerContents res)
-> (HandlerContents
    -> HandlerFor site (Either HandlerContents res))
-> HandlerFor site (Either HandlerContents res)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch (res -> Either HandlerContents res
forall a b. b -> Either a b
Right (res -> Either HandlerContents res)
-> HandlerFor site res
-> HandlerFor site (Either HandlerContents res)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HandlerFor site res
m) ((HandlerContents -> HandlerFor site (Either HandlerContents res))
 -> HandlerFor site (Either HandlerContents res))
-> (HandlerContents
    -> HandlerFor site (Either HandlerContents res))
-> HandlerFor site (Either HandlerContents res)
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
_) -> HandlerContents -> HandlerFor site ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO HandlerContents
e
        HandlerContents
_ -> () -> HandlerFor site ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Either HandlerContents res
-> HandlerFor site (Either HandlerContents res)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HandlerContents -> Either HandlerContents res
forall a b. a -> Either a b
Left (HandlerContents
e :: HandlerContents))
  case Either HandlerContents res
eResult of
    Left HandlerContents
hc -> HandlerContents -> HandlerFor site res
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO HandlerContents
hc
    Right res
normal -> res -> HandlerFor site res
forall (f :: * -> *) a. Applicative f => a -> f a
pure res
normal