diff --git a/users/Profpatsch/my-prelude/src/Builder.hs b/users/Profpatsch/my-prelude/src/Builder.hs
index b5748de77..8af5bba24 100644
--- a/users/Profpatsch/my-prelude/src/Builder.hs
+++ b/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
diff --git a/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs b/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs
index 87928678a..4fe19b41e 100644
--- a/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs
+++ b/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
diff --git a/users/Profpatsch/whatcd-resolver/src/AppT.hs b/users/Profpatsch/whatcd-resolver/src/AppT.hs
index 31f86b83d..e4ffa009e 100644
--- a/users/Profpatsch/whatcd-resolver/src/AppT.hs
+++ b/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
diff --git a/users/Profpatsch/whatcd-resolver/src/Html.hs b/users/Profpatsch/whatcd-resolver/src/Html.hs
index 49b87b23d..dc5202738 100644
--- a/users/Profpatsch/whatcd-resolver/src/Html.hs
+++ b/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|true|]
Json.Bool False -> [hsx|false|]
diff --git a/users/Profpatsch/whatcd-resolver/src/Redacted.hs b/users/Profpatsch/whatcd-resolver/src/Redacted.hs
index 0a2919f40..f667dfbcc 100644
--- a/users/Profpatsch/whatcd-resolver/src/Redacted.hs
+++ b/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
diff --git a/users/Profpatsch/whatcd-resolver/src/Transmission.hs b/users/Profpatsch/whatcd-resolver/src/Transmission.hs
index 3238780af..11a0d565f 100644
--- a/users/Profpatsch/whatcd-resolver/src/Transmission.hs
+++ b/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 "" & toAttribute)
- ]
+ addAttribute span' "transmission.new_session_id" (tid, utf8LenientT)
+ addAttribute span' "transmission.old_session_id" (sessionId, utf8LenientT >&< fromMaybe "")
updateTransmissionSessionId tid
doTransmissionRequest span dat (req, parser)
200 -> do
- addAttributes span $
- HashMap.fromList
- [ ("transmission.valid_session_id", sessionId <&> bytesToTextUtf8Lenient & fromMaybe "" & toAttribute)
- ]
+ addAttribute span "transmission.valid_session_id" (sessionId, utf8LenientT >&< fromMaybe "")
resp
& Http.getResponseBody
& Json.parseStrict
diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
index c5c763226..0d69ec437 100644
--- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
+++ b/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) <-