refactor(users/Profpatsch/whatcd-resolver): use builder for otel

This makes `addAttribute` a little nicer to handle, because we can now
just put a `(builder, value)` tuple (yay, orphan instances!)

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

users/Profpatsch/my-prelude/src/Builder.hs

@@ -11,12 +11,21 @@ module Builder
     bytesLazyB,
     utf8B,
     utf8LazyB,
+    utf8LenientT,
+    utf8LenientLazyT,
     intDecimalT,
-    intDecimalNaturalT,
+    intDecimalB,
+    integerDecimalT,
+    integerDecimalB,
+    naturalDecimalT,
+    naturalDecimalB,
+    scientificDecimalT,
+    scientificDecimalB,
   )
 where
 
 import Data.ByteString.Builder qualified as Bytes
+import Data.ByteString.Builder.Scientific qualified as Scientific.Bytes
 import Data.ByteString.Lazy qualified as Bytes.Lazy
 import Data.Functor.Contravariant
 import Data.Functor.Contravariant.Divisible
@@ -24,6 +33,7 @@ import Data.String
 import Data.Text.Lazy qualified as Text.Lazy
 import Data.Text.Lazy.Builder qualified as Text
 import Data.Text.Lazy.Builder.Int qualified as Text
+import Data.Text.Lazy.Builder.Scientific qualified as Scientific.Text
 import MyPrelude
 
 newtype TextBuilder a = TextBuilder {unTextBuilder :: a -> Text.Builder}
@@ -81,6 +91,12 @@ bytesB = BytesBuilder Bytes.byteString
 bytesLazyB :: BytesBuilder Bytes.Lazy.ByteString
 bytesLazyB = BytesBuilder Bytes.lazyByteString
 
+utf8LenientT :: TextBuilder ByteString
+utf8LenientT = bytesToTextUtf8Lenient >$< textT
+
+utf8LenientLazyT :: TextBuilder Bytes.Lazy.ByteString
+utf8LenientLazyT = bytesToTextUtf8LenientLazy >$< textLazyT
+
 utf8B :: BytesBuilder Text
 utf8B = textToBytesUtf8 >$< bytesB
 
@@ -90,5 +106,23 @@ utf8LazyB = textToBytesUtf8Lazy >$< bytesLazyB
 intDecimalT :: TextBuilder Int
 intDecimalT = TextBuilder Text.decimal
 
-intDecimalNaturalT :: TextBuilder Natural
-intDecimalNaturalT = TextBuilder Text.decimal
+intDecimalB :: BytesBuilder Int
+intDecimalB = BytesBuilder Bytes.intDec
+
+integerDecimalT :: TextBuilder Integer
+integerDecimalT = TextBuilder Text.decimal
+
+integerDecimalB :: BytesBuilder Integer
+integerDecimalB = BytesBuilder Bytes.integerDec
+
+naturalDecimalT :: TextBuilder Natural
+naturalDecimalT = TextBuilder Text.decimal
+
+naturalDecimalB :: BytesBuilder Natural
+naturalDecimalB = toInteger >$< integerDecimalB
+
+scientificDecimalT :: TextBuilder Scientific
+scientificDecimalT = TextBuilder Scientific.Text.scientificBuilder
+
+scientificDecimalB :: BytesBuilder Scientific
+scientificDecimalB = BytesBuilder Scientific.Bytes.scientificBuilder

users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs

@@ -862,17 +862,10 @@ traceQueryIfEnabled span logDatabaseQueries prettyQuery qry params = do
             HasSingleParam p -> pgFormatQuery' prettyQuery qry p
             HasMultiParams ps -> pgFormatQueryMany' prettyQuery qry ps
 
-  let doLog errs =
-        Otel.addAttributes
-          span
-          $ HashMap.fromList
-          $ ( ("_.postgres.query", Otel.toAttribute @Text (errs.query & bytesToTextUtf8Lenient))
-                : ( errs.explain
-                      & \case
-                        Nothing -> []
-                        Just ex -> [("_.postgres.explain", Otel.toAttribute @Text ex)]
-                  )
-            )
+  let doLog errs = do
+        Otel.addAttribute span "_.postgres.query" (errs.query & bytesToTextUtf8Lenient & Otel.toAttribute)
+        for_ errs.explain $ \ex ->
+          Otel.addAttribute span "_.postgres.explain" (Otel.toAttribute @Text ex)
   let doExplain = do
         q <- formattedQuery
         Otel.inSpan "Postgres EXPLAIN Query" Otel.defaultSpanArguments $ do

users/Profpatsch/whatcd-resolver/src/AppT.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE DeriveAnyClass #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
 
 module AppT where
 
+import Builder
 import Control.Monad.Logger qualified as Logger
 import Control.Monad.Logger.CallStack
 import Control.Monad.Reader
@@ -98,6 +100,9 @@ addEventSimple span name =
 jsonAttribute :: Enc -> Otel.Attribute
 jsonAttribute e = e & Enc.encToTextPretty & Otel.toAttribute
 
+instance Otel.ToAttribute (a, TextBuilder a) where
+  toAttribute (a, b) = buildText b a & Otel.toAttribute
+
 parseOrThrow :: (MonadThrow m, MonadIO m) => Otel.Span -> FieldParser from to -> from -> m to
 parseOrThrow span fp f =
   f & Field.runFieldParser fp & \case
@@ -208,6 +213,7 @@ runPGTransaction (Transaction transaction) = do
     withPGTransaction pool $ \conn -> do
       unliftIO $ runReaderT transaction conn
 
+-- | Best effort to convert a value to a JSON string that can be put in an Otel attribute.
 toOtelJsonAttr :: (ToOtelJsonAttr a) => a -> Otel.Attribute
 toOtelJsonAttr = toOtelJsonAttrImpl >>> Enc.encToTextPretty >>> Otel.toAttribute
 
@@ -215,6 +221,9 @@ toOtelJsonAttr = toOtelJsonAttrImpl >>> Enc.encToTextPretty >>> Otel.toAttribute
 class ToOtelJsonAttr a where
   toOtelJsonAttrImpl :: a -> Enc
 
+instance ToOtelJsonAttr Enc where
+  toOtelJsonAttrImpl = id
+
 -- | Bytes are leniently converted to Text, because they are often used as UTF-8 encoded strings.
 instance ToOtelJsonAttr ByteString where
   toOtelJsonAttrImpl = Enc.text . bytesToTextUtf8Lenient

users/Profpatsch/whatcd-resolver/src/Html.hs

@@ -2,6 +2,7 @@
 
 module Html where
 
+import Builder
 import Data.Aeson qualified as Json
 import Data.Aeson.KeyMap qualified as KeyMap
 import Data.List.NonEmpty qualified as NonEmpty
@@ -15,7 +16,7 @@ import Prelude hiding (span)
 -- | Render an arbitrary json value to HTML in a more-or-less reasonable fashion.
 mkVal :: Json.Value -> Html
 mkVal = \case
-  Json.Number n -> Html.toHtml @Text $ showToText n
+  Json.Number n -> Html.lazyText $ buildTextLazy scientificDecimalT n
   Json.String s -> Html.toHtml @Text s
   Json.Bool True -> [hsx|<em>true</em>|]
   Json.Bool False -> [hsx|<em>false</em>|]

users/Profpatsch/whatcd-resolver/src/Redacted.hs

@@ -4,6 +4,7 @@ module Redacted where
 
 import AppT
 import Arg
+import Builder
 import Comparison
 import Control.Monad.Logger.CallStack
 import Control.Monad.Reader
@@ -65,7 +66,7 @@ redactedGetTorrentFile dat = inSpan' "Redacted Get Torrent File" $ \span -> do
       ( T2
           (label @"action" "download")
           ( label @"actionArgs"
-              [ ("id", Just (dat.torrentId & showToText @Int & textToBytesUtf8))
+              [ ("id", Just (buildBytes intDecimalB dat.torrentId))
               -- try using tokens as long as we have them (TODO: what if there’s no tokens left?
               -- ANSWER: it breaks:
               -- responseBody = "{\"status\":\"failure\",\"error\":\"You do not have any freeleech tokens left. Please use the regular DL link.\"}",
@@ -139,7 +140,7 @@ redactedSearchAndInsert extraArguments = do
       redactedSearch
         ( extraArguments
             -- pass the page (for every search but the first one)
-            <> (mpage & ifExists (\page -> ("page", (page :: Natural) & showToText & textToBytesUtf8)))
+            <> (mpage & ifExists (\page -> ("page", buildBytes naturalDecimalB page)))
         )
         ( do
             status <- Json.key "status" Json.asText

users/Profpatsch/whatcd-resolver/src/Transmission.hs

@@ -3,6 +3,7 @@
 module Transmission where
 
 import AppT
+import Builder
 import Control.Monad.Logger.CallStack
 import Control.Monad.Reader
 import Data.Aeson qualified as Json
@@ -25,7 +26,6 @@ import Json.Enc qualified as Enc
 import Label
 import MyPrelude
 import Network.HTTP.Types
-import OpenTelemetry.Attributes (ToAttribute (toAttribute))
 import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan')
 import Optional
 import Postgres.MonadPostgres
@@ -253,7 +253,7 @@ doTransmissionRequest ::
 doTransmissionRequest span dat (req, parser) = do
   sessionId <- getCurrentTransmissionSessionId
   let textArg t = (Enc.text t, Otel.toAttribute @Text t)
-  let encArg enc = (enc, Otel.toAttribute @Text $ enc & Enc.encToTextPretty)
+  let encArg enc = (enc, enc & toOtelJsonAttr)
   let intArg i = (Enc.int i, Otel.toAttribute @Int i)
 
   let body :: [(Text, (Enc, Otel.Attribute))] =
@@ -292,20 +292,14 @@ doTransmissionRequest span dat (req, parser) = do
           & liftIO
           <&> NonEmpty.head
 
-      addAttributes span' $
-        HashMap.fromList
-          [ ("transmission.new_session_id", tid & bytesToTextUtf8Lenient & toAttribute),
-            ("transmission.old_session_id", sessionId <&> bytesToTextUtf8Lenient & fromMaybe "<none yet>" & toAttribute)
-          ]
+      addAttribute span' "transmission.new_session_id" (tid, utf8LenientT)
+      addAttribute span' "transmission.old_session_id" (sessionId, utf8LenientT >&< fromMaybe "<none yet>")
 
       updateTransmissionSessionId tid
 
       doTransmissionRequest span dat (req, parser)
     200 -> do
-      addAttributes span $
-        HashMap.fromList
-          [ ("transmission.valid_session_id", sessionId <&> bytesToTextUtf8Lenient & fromMaybe "<none yet>" & toAttribute)
-          ]
+      addAttribute span "transmission.valid_session_id" (sessionId, utf8LenientT >&< fromMaybe "<none yet>")
       resp
         & Http.getResponseBody
         & Json.parseStrict

users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs

@@ -5,6 +5,7 @@ module WhatcdResolver where
 
 import AppT
 import Arg
+import Builder
 import Comparison
 import Control.Category qualified as Cat
 import Control.Monad.Catch.Pure (runCatch)
@@ -562,7 +563,7 @@ getBestTorrentsData ::
   Maybe (Label "artistRedactedId" Natural) ->
   Transaction m [TorrentData (Label "percentDone" Percentage)]
 getBestTorrentsData artistFilter = inSpan' "get torrents table data" $ \span -> do
-  artistFilter & doIfJust (\a -> addAttribute span "artist-filter.redacted-id" (a.artistRedactedId & showToText & Otel.toAttribute))
+  artistFilter & doIfJust (\a -> addAttribute span "artist-filter.redacted-id" (a.artistRedactedId, naturalDecimalT))
   let getBest = getBestTorrents GetBestTorrentsFilter {onlyArtist = artistFilter, onlyDownloaded = False}
   bestStale :: [TorrentData ()] <- getBest
   (statusInfo, transmissionStatus) <-