feat(users/Profpatsch/whatcd-resolver): add ToOtelJsonAttr

Small helper class for putting a json otel attribute from random
types, via Enc.

Used for the redacted requests for now.

Change-Id: I29c31de01f1f5eb3f63ce5639e5b4df4f9b0dc40
Reviewed-on: https://cl.tvl.fyi/c/depot/+/12953
Tested-by: BuildkiteCI
Reviewed-by: Profpatsch <mail@profpatsch.de>

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

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

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

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 =
+redactedApiRequestJson span dat parser = do
-  do
+  addAttribute span "redacted.request" (toOtelJsonAttr (T2 (getLabel @"action" dat) (getLabel @"actionArgs" dat)))
-    mkRedactedApiRequest dat
+  mkRedactedApiRequest dat
     >>= Http.httpJson defaults parser