diff --git a/users/Profpatsch/my-prelude/src/Json/Enc.hs b/users/Profpatsch/my-prelude/src/Json/Enc.hs index c7cd6e463..2c2524095 100644 --- a/users/Profpatsch/my-prelude/src/Json/Enc.hs +++ b/users/Profpatsch/my-prelude/src/Json/Enc.hs @@ -127,6 +127,12 @@ nullOr inner = \case list :: (a -> Enc) -> [a] -> Enc list f = Enc . AesonEnc.list (\a -> (f a).unEnc) +tuple2 :: (a -> Enc) -> (b -> Enc) -> (a, b) -> Enc +tuple2 f g (a, b) = list id [f a, g b] + +tuple3 :: (a -> Enc) -> (b -> Enc) -> (c -> Enc) -> (a, b, c) -> Enc +tuple3 f g h (a, b, c) = list id [f a, g b, h c] + -- | Encode a 'NonEmpty' as a json list. nonEmpty :: (a -> Enc) -> NonEmpty a -> Enc nonEmpty f = list f . toList diff --git a/users/Profpatsch/my-prelude/src/MyPrelude.hs b/users/Profpatsch/my-prelude/src/MyPrelude.hs index 880983c47..4a8b76ba4 100644 --- a/users/Profpatsch/my-prelude/src/MyPrelude.hs +++ b/users/Profpatsch/my-prelude/src/MyPrelude.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} @@ -161,6 +162,7 @@ module MyPrelude -- * Error handling HasCallStack, module Data.Error, + symbolText, ) where @@ -223,9 +225,9 @@ import Data.Word (Word8) import GHC.Exception (errorCallWithCallStackException) import GHC.Exts (Any, RuntimeRep, TYPE, raise#) import GHC.Generics (Generic) -import GHC.Natural (Natural) import GHC.Records (HasField) import GHC.Stack (HasCallStack) +import GHC.TypeLits import GHC.Utils.Encoding qualified as GHC import Language.Haskell.TH.Syntax (Lift) import PyF (fmt) @@ -774,3 +776,9 @@ ifTrue pred' m = if pred' then m else mempty ifExists :: (Monoid (f b), Applicative f) => (a -> b) -> Maybe a -> f b ifExists f m = m & foldMap @Maybe (pure . f) + +-- | Get the text of a symbol via TypeApplications +symbolText :: forall sym. (KnownSymbol sym) => Text +symbolText = do + symbolVal (Proxy :: Proxy sym) + & stringToText diff --git a/users/Profpatsch/whatcd-resolver/src/AppT.hs b/users/Profpatsch/whatcd-resolver/src/AppT.hs index 8550d4aa7..31f86b83d 100644 --- a/users/Profpatsch/whatcd-resolver/src/AppT.hs +++ b/users/Profpatsch/whatcd-resolver/src/AppT.hs @@ -14,14 +14,16 @@ import Data.Text qualified as Text import Database.PostgreSQL.Simple qualified as Postgres import FieldParser (FieldParser) import FieldParser qualified as Field +import GHC.Records (getField) import GHC.Stack qualified +import GHC.TypeLits import Json.Enc import Json.Enc qualified as Enc import Label +import MyPrelude import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan') import OpenTelemetry.Trace.Core qualified as Otel hiding (inSpan, inSpan') import OpenTelemetry.Trace.Monad qualified as Otel -import PossehlAnalyticsPrelude import Postgres.MonadPostgres import Pretty qualified import System.IO qualified as IO @@ -205,3 +207,55 @@ runPGTransaction (Transaction transaction) = do withRunInIO $ \unliftIO -> withPGTransaction pool $ \conn -> do unliftIO $ runReaderT transaction conn + +toOtelJsonAttr :: (ToOtelJsonAttr a) => a -> Otel.Attribute +toOtelJsonAttr = toOtelJsonAttrImpl >>> Enc.encToTextPretty >>> Otel.toAttribute + +-- | Best effort to convert a value to a JSON string that can be put in an Otel attribute. +class ToOtelJsonAttr a where + toOtelJsonAttrImpl :: a -> Enc + +-- | Bytes are leniently converted to Text, because they are often used as UTF-8 encoded strings. +instance ToOtelJsonAttr ByteString where + toOtelJsonAttrImpl = Enc.text . bytesToTextUtf8Lenient + +instance ToOtelJsonAttr Text where + toOtelJsonAttrImpl = Enc.text + +instance ToOtelJsonAttr Int where + toOtelJsonAttrImpl = Enc.int + +instance ToOtelJsonAttr Natural where + toOtelJsonAttrImpl = Enc.natural + +instance ToOtelJsonAttr Bool where + toOtelJsonAttrImpl = Enc.bool + +instance (ToOtelJsonAttr a) => ToOtelJsonAttr (Maybe a) where + toOtelJsonAttrImpl = \case + Nothing -> Enc.null + Just a -> toOtelJsonAttrImpl a + +instance (ToOtelJsonAttr a) => ToOtelJsonAttr [a] where + toOtelJsonAttrImpl = Enc.list toOtelJsonAttrImpl + +instance (ToOtelJsonAttr t1, ToOtelJsonAttr t2, KnownSymbol l1, KnownSymbol l2) => ToOtelJsonAttr (T2 l1 t1 l2 t2) where + toOtelJsonAttrImpl (T2 a b) = + Enc.object + [ (symbolText @l1, a & getField @l1 & toOtelJsonAttrImpl), + (symbolText @l2, b & getField @l2 & toOtelJsonAttrImpl) + ] + +instance (ToOtelJsonAttr t1, ToOtelJsonAttr t2, ToOtelJsonAttr t3, KnownSymbol l1, KnownSymbol l2, KnownSymbol l3) => ToOtelJsonAttr (T3 l1 t1 l2 t2 l3 t3) where + toOtelJsonAttrImpl (T3 a b c) = + Enc.object + [ (symbolText @l1, a & getField @l1 & toOtelJsonAttrImpl), + (symbolText @l2, b & getField @l2 & toOtelJsonAttrImpl), + (symbolText @l3, c & getField @l3 & toOtelJsonAttrImpl) + ] + +instance (ToOtelJsonAttr t1, ToOtelJsonAttr t2) => ToOtelJsonAttr (t1, t2) where + toOtelJsonAttrImpl t = Enc.tuple2 toOtelJsonAttrImpl toOtelJsonAttrImpl t + +instance (ToOtelJsonAttr t1, ToOtelJsonAttr t2, ToOtelJsonAttr t3) => ToOtelJsonAttr (t1, t2, t3) where + toOtelJsonAttrImpl t = Enc.tuple3 toOtelJsonAttrImpl toOtelJsonAttrImpl toOtelJsonAttrImpl t diff --git a/users/Profpatsch/whatcd-resolver/src/Redacted.hs b/users/Profpatsch/whatcd-resolver/src/Redacted.hs index 209b8eae1..e6a1b4be2 100644 --- a/users/Profpatsch/whatcd-resolver/src/Redacted.hs +++ b/users/Profpatsch/whatcd-resolver/src/Redacted.hs @@ -40,8 +40,9 @@ redactedSearch :: Json.Parse ErrorTree a -> m a redactedSearch advanced parser = - inSpan "Redacted API Search" $ + inSpan' "Redacted API Search" $ \span -> redactedApiRequestJson + span ( T2 (label @"action" "browse") (label @"actionArgs" ((advanced <&> second Just))) @@ -571,10 +572,11 @@ redactedApiRequestJson :: MonadOtel m, MonadRedacted m ) => + Otel.Span -> p -> Json.Parse ErrorTree a -> m a -redactedApiRequestJson dat parser = - do - mkRedactedApiRequest dat +redactedApiRequestJson span dat parser = do + addAttribute span "redacted.request" (toOtelJsonAttr (T2 (getLabel @"action" dat) (getLabel @"actionArgs" dat))) + mkRedactedApiRequest dat >>= Http.httpJson defaults parser