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) <-