From 3040fe2e908d0018826adbed796b1ba4fd5b69d0 Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Mon, 6 Jan 2025 17:21:12 +0100 Subject: [PATCH] feat(users/Profpatsch/whatcd-resolver): implement artist refresh v0 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This is kind of a chonker because I went into so many rabbit holes. Foremost this implements a simple “Refresh Artist” button that fetches current artist torrent groups. BUG: the `artist` endpoint torrent struct is shite, it’s missing most info that we get in the `search` endpoint torrent struct, plus it’s organized differently (e.g. the `artists` thingy is in the torrent_group not the torrent). I should switch everything over to fetching the `torrent_group.id`s first and then going through and slowly fetching every torrent group separately … however that might time out very quickly. ugh. There doesn’t seem to be a way of fetching multiple torrent groups. Random other shit & improvements: * intersperse for builders * fix json errors so that the structs don’t get too big (`restrictJson`) * show error messages as json so jaeger displays it with nested UI * color pretty-printed json outpt on command line * add some important integral functions to MyPrelude * add `sintersperse` and `mintersperse` to MyPrelude Change-Id: If8bfcd68dc5c905e118ad86d50d7416962bf55d4 Reviewed-on: https://cl.tvl.fyi/c/depot/+/12960 Tested-by: BuildkiteCI Reviewed-by: Profpatsch --- users/Profpatsch/my-prelude/src/Builder.hs | 16 + users/Profpatsch/my-prelude/src/Json.hs | 158 +++++++-- users/Profpatsch/my-prelude/src/Json/Enc.hs | 28 +- users/Profpatsch/my-prelude/src/MyPrelude.hs | 44 ++- users/Profpatsch/my-prelude/src/Pretty.hs | 15 +- users/Profpatsch/whatcd-resolver/src/AppT.hs | 4 + users/Profpatsch/whatcd-resolver/src/Http.hs | 12 +- .../whatcd-resolver/src/Redacted.hs | 317 +++++++++++++----- .../whatcd-resolver/src/WhatcdResolver.hs | 153 ++++++--- 9 files changed, 584 insertions(+), 163 deletions(-) diff --git a/users/Profpatsch/my-prelude/src/Builder.hs b/users/Profpatsch/my-prelude/src/Builder.hs index 8af5bba24..80b43985c 100644 --- a/users/Profpatsch/my-prelude/src/Builder.hs +++ b/users/Profpatsch/my-prelude/src/Builder.hs @@ -21,6 +21,8 @@ module Builder naturalDecimalB, scientificDecimalT, scientificDecimalB, + intersperseT, + intersperseB, ) where @@ -126,3 +128,17 @@ scientificDecimalT = TextBuilder Scientific.Text.scientificBuilder scientificDecimalB :: BytesBuilder Scientific scientificDecimalB = BytesBuilder Scientific.Bytes.scientificBuilder + +-- TODO: can these be abstracted over Divisible & Semigroup? Or something? + +intersperseT :: (forall b. TextBuilder b) -> TextBuilder a -> TextBuilder [a] +intersperseT sep a = ((),) >$< intersperseT' sep a + +intersperseT' :: TextBuilder b -> TextBuilder a -> TextBuilder (b, [a]) +intersperseT' (TextBuilder sep) (TextBuilder a) = TextBuilder $ \(b, as) -> mintersperse (sep b) (fmap a as) + +intersperseB :: (forall b. BytesBuilder b) -> BytesBuilder a -> BytesBuilder [a] +intersperseB sep a = ((),) >$< intersperseB' sep a + +intersperseB' :: BytesBuilder b -> BytesBuilder a -> BytesBuilder (b, [a]) +intersperseB' (BytesBuilder sep) (BytesBuilder a) = BytesBuilder $ \(b, as) -> mintersperse (sep b) (fmap a as) diff --git a/users/Profpatsch/my-prelude/src/Json.hs b/users/Profpatsch/my-prelude/src/Json.hs index 1e0d14f05..a1a41fd34 100644 --- a/users/Profpatsch/my-prelude/src/Json.hs +++ b/users/Profpatsch/my-prelude/src/Json.hs @@ -1,8 +1,10 @@ {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE UndecidableInstances #-} module Json where +import Builder import Data.Aeson (FromJSON (parseJSON), ToJSON (toEncoding, toJSON), Value (..), withObject) import Data.Aeson qualified as Json import Data.Aeson.BetterErrors qualified as Json @@ -19,9 +21,10 @@ import Data.Time (UTCTime) import Data.Vector qualified as Vector import FieldParser (FieldParser) import FieldParser qualified as Field +import Json.Enc (Enc) +import Json.Enc qualified as Enc import Label import MyPrelude -import Pretty -- | Use a "Data.Aeson.BetterErrors" parser to implement 'FromJSON'’s 'parseJSON' method. -- @@ -71,11 +74,12 @@ parseErrorTree contextMsg errs = & singleError & nestedError contextMsg --- | Convert a 'Json.ParseError' to a corresponding 'ErrorTree' +-- | Convert a 'Json.ParseError' to a pair of error message and a shrunken-down +-- version of the value at the path where the error occurred. -- -- This version shows some of the value at the path where the error occurred. -parseErrorTreeValCtx :: Error -> Json.Value -> Json.ParseError ErrorTree -> ErrorTree -parseErrorTreeValCtx contextMsg origValue errs = do +parseErrorTreeValCtx :: Json.Value -> Json.ParseError ErrorTree -> T2 "errorMessage" Enc "valueAtErrorPath" (Maybe Json.Value) +parseErrorTreeValCtx origValue errs = do let ctxPath = case errs of Json.BadSchema path _spec -> Just path _ -> Nothing @@ -88,33 +92,57 @@ parseErrorTreeValCtx contextMsg origValue errs = do Nothing -> v Just v' -> go v' path - ( ( errs - & Json.displayError prettyErrorTree - & Text.intercalate "\n" - & newError + T2 + ( label @"errorMessage" $ + errs + & displayErrorCustom ) - :| ( maybe - [] - ( \ctx -> - [ go origValue ctx - & Pretty.showPrettyJson - & newError - ] - ) - ctxPath - ) + ( label @"valueAtErrorPath" $ + ctxPath + <&> ( go origValue + -- make sure we don’t explode the error message by showing too much of the value + >>> restrictJson restriction + ) ) - -- We nest this here because the json errors is multiline, so the result looks like - -- - -- @ - -- contextMsg - -- \| - -- `- At the path: ["foo"]["bar"] - -- Type mismatch: - -- Expected a value of type object - -- Got: true - -- @ - & errorTree contextMsg + where + restriction = + RestrictJsonOpts + { maxDepth = 2, + maxSizeObject = 10, + maxSizeArray = 3, + maxStringLength = 100 + } + displayErrorCustom :: Json.ParseError ErrorTree -> Enc + displayErrorCustom = \case + Json.InvalidJSON str -> + ["The input could not be parsed as JSON: " <> str & stringToText] + & Enc.list Enc.text + Json.BadSchema path spec -> do + let pieceEnc = \case + Json.ObjectKey k -> Enc.text k + Json.ArrayIndex i -> Enc.int i + case spec of + Json.WrongType t val -> + Enc.object + [ ("@", Enc.list pieceEnc path), + ( "error", + -- not showing the value here, because we are gonna show it anyway in the valueAtErrorPath + [fmt|Expected a value of type `{displayJSONType t}` but got one of type `{val & Json.jsonTypeOf & displayJSONType}`|] + ) + ] + other -> + Json.displaySpecifics prettyErrorTree other + & Text.intercalate "\n" + & Enc.text + + displayJSONType :: Json.JSONType -> Text + displayJSONType t = case t of + Json.TyObject -> "object" + Json.TyArray -> "array" + Json.TyString -> "string" + Json.TyNumber -> "number" + Json.TyBool -> "boolean" + Json.TyNull -> "null" -- | Lift the parser error to an error tree asErrorTree :: (Functor m) => Json.ParseT Error m a -> Json.ParseT ErrorTree m a @@ -304,3 +332,75 @@ instance ToJSON EmptyObject where -- | Create a json array from a list of json values. mkJsonArray :: [Value] -> Value mkJsonArray xs = xs & Vector.fromList & Array + +data RestrictJsonOpts = RestrictJsonOpts + { maxDepth :: Natural, + maxSizeObject :: Natural, + maxSizeArray :: Natural, + maxStringLength :: Natural + } + +-- | Restrict a json object so that its depth and size are within the given bounds. +-- +-- Bounds are maximum 'Int' width. +restrictJson :: + RestrictJsonOpts -> + Value -> + Value +restrictJson opts = do + let maxSizeObject = opts.maxSizeObject & naturalToInteger & integerToBoundedClamped + let maxSizeArray = opts.maxSizeArray & naturalToInteger & integerToBoundedClamped + let maxStringLength = opts.maxStringLength & naturalToInteger & integerToBoundedClamped + go (opts.maxDepth, maxSizeObject, maxSizeArray, maxStringLength) + where + go (0, _, _, strLen) (Json.String s) = truncateString strLen s + go (0, _, _, _) (Json.Array arr) = Array $ Vector.singleton [fmt|<{Vector.length arr} elements elided>|] + go (0, _, _, _) (Json.Object obj) = + obj + & buildText (KeyMap.keys >$< (" intersperseT ", " (Key.toText >$< textT) <> "}>")) + & String + go (depth, sizeObject, sizeArray, strLen) val = case val of + Object obj -> + obj + & ( \m -> + if KeyMap.size m > sizeObject + then + m + & KeyMap.toList + & take sizeObject + & KeyMap.fromList + & KeyMap.map (go (depth - 1, sizeObject, sizeArray, strLen)) + & \smol -> + smol + & KeyMap.insert + "" + (m `KeyMap.difference` smol & KeyMap.keys & toJSON) + else + m + & KeyMap.map (go (depth - 1, sizeObject, sizeArray, strLen)) + ) + & Json.Object + Array arr -> + arr + & ( \v -> + if Vector.length v > sizeArray + then + v + & Vector.take sizeArray + & Vector.map (go (depth - 1, sizeObject, sizeArray, strLen)) + & (\v' -> Vector.snoc v' ([fmt|<{Vector.length v - sizeArray} more elements elided>|] & String)) + else + v + & Vector.map (go (depth - 1, sizeObject, sizeArray, strLen)) + ) + & Array + String txt -> truncateString strLen txt + other -> other + + truncateString strLen txt = + let truncatedTxt = Text.take strLen txt + finalTxt = + if Text.length txt > strLen + then Text.append truncatedTxt "…" + else truncatedTxt + in String finalTxt diff --git a/users/Profpatsch/my-prelude/src/Json/Enc.hs b/users/Profpatsch/my-prelude/src/Json/Enc.hs index 2c2524095..0d08bc46b 100644 --- a/users/Profpatsch/my-prelude/src/Json/Enc.hs +++ b/users/Profpatsch/my-prelude/src/Json/Enc.hs @@ -26,6 +26,7 @@ import Data.Time qualified as Time import Data.Time.Format.ISO8601 qualified as ISO8601 import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) import PossehlAnalyticsPrelude +import Pretty (hscolour') -- | A JSON encoder. -- @@ -53,18 +54,18 @@ instance RationalLiteral Enc where -- | Convert an 'Enc' to a strict UTF8-bytestring which is valid JSON (minified). encToBytesUtf8 :: Enc -> ByteString -encToBytesUtf8 enc = enc & encToBytesUtf8Lazy & toStrictBytes +encToBytesUtf8 enc' = enc' & encToBytesUtf8Lazy & toStrictBytes -- | Convert an 'Enc' to a lazy UTF8-bytestring which is valid JSON (minified). encToBytesUtf8Lazy :: Enc -> LazyBytes.ByteString -encToBytesUtf8Lazy enc = enc.unEnc & Json.Enc.encodingToLazyByteString +encToBytesUtf8Lazy enc' = enc'.unEnc & Json.Enc.encodingToLazyByteString -- | Convert an 'Enc' to a strict Text which is valid JSON (prettyfied). -- -- __ATTN__: will re-parse the json through 'Json.Value', so only use for user-interactions like pretty-printing. encToTextPretty :: Enc -> Text -encToTextPretty enc = - enc +encToTextPretty enc' = + enc' & encToTextPrettyLazy & toStrict @@ -72,8 +73,8 @@ encToTextPretty enc = -- -- __ATTN__: will re-parse the json through 'Json.Value', so only use for user-interactions like pretty-printing. encToTextPrettyLazy :: Enc -> Lazy.Text -encToTextPrettyLazy enc = - enc +encToTextPrettyLazy enc' = + enc' & encToBytesUtf8Lazy & Json.decode @Json.Value & annotate "the json parser can’t parse json encodings??" @@ -81,6 +82,17 @@ encToTextPrettyLazy enc = & Aeson.Pretty.encodePrettyToTextBuilder & Text.Builder.toLazyText +-- | Convert an 'Enc' to a strict Text which is valid JSON (prettyfied and colored). +-- +-- __ATTN__: will re-parse the json through 'Json.Value', so only use for user-interactions like pretty-printing. +encToTextPrettyColored :: Enc -> Text +encToTextPrettyColored enc' = + enc' + & encToTextPretty + & textToString + & hscolour' + & stringToText + -- | Embed a 'Json.Encoding' verbatim (it’s a valid JSON value) encoding :: Encoding -> Enc encoding = Enc @@ -89,6 +101,10 @@ encoding = Enc value :: Value -> Enc value = Enc . AesonEnc.value +-- | Encode an Enc verbatim (for completeness’ sake) +enc :: Enc -> Enc +enc = id + -- | Encode an empty json list emptyArray :: Enc emptyArray = Enc AesonEnc.emptyArray_ diff --git a/users/Profpatsch/my-prelude/src/MyPrelude.hs b/users/Profpatsch/my-prelude/src/MyPrelude.hs index 661e4efc9..8ed475236 100644 --- a/users/Profpatsch/my-prelude/src/MyPrelude.hs +++ b/users/Profpatsch/my-prelude/src/MyPrelude.hs @@ -130,11 +130,16 @@ module MyPrelude mconcat, ifTrue, ifExists, + sintersperse, + mintersperse, Void, absurd, Identity (Identity, runIdentity), Natural, + naturalToInteger, intToNatural, + integerToBounded, + integerToBoundedClamped, Scientific, Contravariant, contramap, @@ -196,6 +201,7 @@ import Data.Functor ((<&>)) import Data.Functor.Contravariant (Contravariant (contramap), (>$<)) import Data.Functor.Identity (Identity (runIdentity)) import Data.List (zip4) +import Data.List qualified as List import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict @@ -207,7 +213,7 @@ import Data.Maybe qualified as Maybe import Data.Profunctor (Profunctor, dimap, lmap, rmap) import Data.Scientific (Scientific) import Data.Semigroup (sconcat) -import Data.Semigroup.Foldable (Foldable1 (fold1), foldMap1) +import Data.Semigroup.Foldable (Foldable1 (fold1, toNonEmpty), foldMap1) import Data.Semigroup.Traversable (Traversable1) import Data.Semigroupoid (Semigroupoid (o)) import Data.Text @@ -227,6 +233,7 @@ import Divisive import GHC.Exception (errorCallWithCallStackException) import GHC.Exts (Any, RuntimeRep, TYPE, raise#) import GHC.Generics (Generic) +import GHC.Natural (naturalToInteger) import GHC.Records (HasField) import GHC.Stack (HasCallStack) import GHC.TypeLits @@ -653,6 +660,27 @@ intToNatural i = then Nothing else Just $ fromIntegral i +-- | Convert an Integer to a bounded type if possible. +-- +-- taken from 'Scientific.toBoundedInteger'. +integerToBounded :: forall i. (Bounded i, Integral i) => Integer -> Maybe i +integerToBounded i + | i < iMinBound || i > iMaxBound = Nothing + | otherwise = Just $ fromInteger i + where + iMinBound = toInteger (minBound :: i) + iMaxBound = toInteger (maxBound :: i) + +-- | Convert an Integer to a bounded type, clamping to the bounds if necessary. +integerToBoundedClamped :: forall i. (Bounded i, Integral i) => Integer -> i +integerToBoundedClamped i + | i < iMinBound = minBound + | i > iMaxBound = maxBound + | otherwise = fromInteger i + where + iMinBound = toInteger (minBound :: i) + iMaxBound = toInteger (maxBound :: i) + -- | @inverseFunction f@ creates a function that is the inverse of a given function -- @f@. It does so by constructing 'M.Map' internally for each value @f a@. The -- implementation makes sure that the 'M.Map' is constructed only once and then @@ -758,7 +786,6 @@ mapFromListOnMerge f xs = -- >>> mconcat [ Sum 1, ifTrue (1 == 1) (Sum 2), Sum 3 ] -- Sum {getSum = 6} - ifTrue :: (Monoid m) => Bool -> m -> m ifTrue pred' m = if pred' then m else mempty @@ -775,10 +802,21 @@ ifTrue pred' m = if pred' then m else mempty -- -- >>> mconcat [ Sum 1, ifExists id (Just 2), Sum 3 ] -- Sum {getSum = 6} - ifExists :: (Monoid (f b), Applicative f) => (a -> b) -> Maybe a -> f b ifExists f m = m & foldMap @Maybe (pure . f) +-- | Intersperse a monoidal value between each element of a list. +-- +-- Generalization of 'Data.List.intersperse' to any 'Foldable' and 'Semigroup'. +sintersperse :: (Foldable1 t, Semigroup m) => m -> t m -> m +sintersperse sep xs = xs & toNonEmpty & NonEmpty.intersperse sep & sconcat + +-- | Intersperse a monoidal value between each element of a list. If the list is empty, return 'mempty'. +-- +-- Generalization of 'Data.List.intersperse' to any 'Foldable' and 'Monoid'. +mintersperse :: (Foldable t, Monoid m) => m -> t m -> m +mintersperse sep xs = xs & toList & List.intersperse sep & mconcat + -- | Get the text of a symbol via TypeApplications symbolText :: forall sym. (KnownSymbol sym) => Text symbolText = do diff --git a/users/Profpatsch/my-prelude/src/Pretty.hs b/users/Profpatsch/my-prelude/src/Pretty.hs index 6711ea951..3022e1368 100644 --- a/users/Profpatsch/my-prelude/src/Pretty.hs +++ b/users/Profpatsch/my-prelude/src/Pretty.hs @@ -3,6 +3,7 @@ module Pretty Err, showPretty, showPrettyJson, + showPrettyJsonColored, showedStringPretty, printPretty, printShowedStringPretty, @@ -63,6 +64,17 @@ showPrettyJson val = & Text.Builder.toLazyText & toStrict +-- | Shows a pretty json string with some color (very inefficient!) +showPrettyJsonColored :: Json.Value -> Text +showPrettyJsonColored val = + val + & Aeson.Pretty.encodePrettyToTextBuilder + & Text.Builder.toLazyText + & toStrict + & textToString + & hscolour' + & stringToText + -- | Display a list of 'Err's as a colored error message prettyErrs :: [Err] -> String prettyErrs errs = res @@ -71,7 +83,8 @@ prettyErrs errs = res one = \case ErrMsg s -> color Red s ErrPrettyString s -> prettyShowString s - -- Pretty print a String that was produced by 'show' + + -- \| Pretty print a String that was produced by 'show' prettyShowString :: String -> String prettyShowString = hscolour' . nicify diff --git a/users/Profpatsch/whatcd-resolver/src/AppT.hs b/users/Profpatsch/whatcd-resolver/src/AppT.hs index e4ffa009e..831a17edc 100644 --- a/users/Profpatsch/whatcd-resolver/src/AppT.hs +++ b/users/Profpatsch/whatcd-resolver/src/AppT.hs @@ -51,6 +51,7 @@ newtype AppT m a = AppT {unAppT :: ReaderT Context m a} data AppException = AppExceptionTree ErrorTree | AppExceptionPretty [Pretty.Err] + | AppExceptionEnc Enc deriving anyclass (Exception) instance IsString AppException where @@ -59,6 +60,7 @@ instance IsString AppException where instance Show AppException where showsPrec _ (AppExceptionTree t) = ("AppException: " ++) . ((textToString $ prettyErrorTree t) ++) showsPrec _ (AppExceptionPretty t) = ("AppException: " ++) . ((Pretty.prettyErrsNoColor t) ++) + showsPrec _ (AppExceptionEnc e) = ((textToString $ Enc.encToTextPretty e) ++) instance (MonadIO m) => MonadLogger (AppT m) where monadLoggerLog loc src lvl msg = liftIO $ Logger.defaultOutput IO.stderr loc src lvl (Logger.toLogStr msg) @@ -119,6 +121,7 @@ appThrowNewSpan spanName exc = inSpan' spanName $ \span -> do let msg = case exc of AppExceptionTree e -> prettyErrorTree e AppExceptionPretty p -> Pretty.prettyErrsNoColor p & stringToText + AppExceptionEnc e -> Enc.encToTextPretty e recordException span ( T2 @@ -132,6 +135,7 @@ appThrow span exc = do let msg = case exc of AppExceptionTree e -> prettyErrorTree e AppExceptionPretty p -> Pretty.prettyErrsNoColor p & stringToText + AppExceptionEnc e -> Enc.encToTextPretty e recordException span ( T2 diff --git a/users/Profpatsch/whatcd-resolver/src/Http.hs b/users/Profpatsch/whatcd-resolver/src/Http.hs index a9aa23495..f710af92e 100644 --- a/users/Profpatsch/whatcd-resolver/src/Http.hs +++ b/users/Profpatsch/whatcd-resolver/src/Http.hs @@ -127,8 +127,16 @@ httpJson opts parser req = inSpan' "HTTP Request (JSON)" $ \span -> do let res = Json.parseValue parser val case res of Left e -> do - let prettyErr = Json.parseErrorTreeValCtx "could not parse HTTP response" val e - appThrow span (AppExceptionTree prettyErr) + let err = Json.parseErrorTreeValCtx val e + appThrow + span + ( AppExceptionEnc $ + Enc.tuple3 + Enc.text + Enc.enc + (Enc.nullOr Enc.value) + ("Could not parse HTTP response", err.errorMessage, err.valueAtErrorPath) + ) Right a -> pure a hush :: Either e a -> Maybe a diff --git a/users/Profpatsch/whatcd-resolver/src/Redacted.hs b/users/Profpatsch/whatcd-resolver/src/Redacted.hs index ce7654556..30a75ff73 100644 --- a/users/Profpatsch/whatcd-resolver/src/Redacted.hs +++ b/users/Profpatsch/whatcd-resolver/src/Redacted.hs @@ -10,9 +10,11 @@ import Control.Monad.Logger.CallStack import Control.Monad.Reader import Data.Aeson qualified as Json import Data.Aeson.BetterErrors qualified as Json +import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KeyMap import Data.Error.Tree import Data.List qualified as List +import Data.List.NonEmpty qualified as NonEmpty import Data.Maybe (catMaybes) import Database.PostgreSQL.Simple (Binary (Binary), Only (..)) import Database.PostgreSQL.Simple.Types (PGArray (PGArray)) @@ -37,20 +39,75 @@ instance (MonadIO m) => MonadRedacted (AppT m) where getRedactedApiKey = AppT (asks (.redactedApiKey)) redactedSearch :: - (MonadThrow m, MonadOtel m, MonadRedacted m) => - [(ByteString, ByteString)] -> + ( MonadThrow m, + MonadOtel m, + MonadRedacted m, + HasField "actionArgs" extraArguments [(ByteString, ByteString)], + HasField "page" dat (Maybe Natural) + ) => + extraArguments -> + dat -> Json.Parse ErrorTree a -> m a -redactedSearch advanced parser = +redactedSearch extraArguments dat parser = inSpan' "Redacted API Search" $ \span -> - redactedApiRequestJson + redactedPagedRequest span - ( T2 + ( T3 (label @"action" "browse") - (label @"actionArgs" ((advanced <&> second Just))) + (getLabel @"actionArgs" extraArguments) + (getLabel @"page" dat) ) parser +redactedGetArtist :: + ( MonadOtel m, + MonadThrow m, + MonadRedacted m, + HasField "artistId" r Text, + HasField "page" r (Maybe Natural) + ) => + r -> + Json.Parse ErrorTree a -> + m a +redactedGetArtist dat parser = + inSpan' "Redacted Get Artist" $ \span -> do + redactedPagedRequest + span + ( T3 + (label @"action" "artist") + (label @"actionArgs" [("id", buildBytes utf8B dat.artistId)]) + (getLabel @"page" dat) + ) + parser + +redactedPagedRequest :: + ( MonadThrow m, + MonadOtel m, + MonadRedacted m, + HasField "action" dat ByteString, + HasField "actionArgs" dat [(ByteString, ByteString)], + HasField "page" dat (Maybe Natural) + ) => + Otel.Span -> + dat -> + Json.Parse ErrorTree a -> + m a +redactedPagedRequest span dat parser = + redactedApiRequestJson + span + ( T2 + (label @"action" dat.action) + ( label @"actionArgs" $ + (dat.actionArgs <&> second Just) + <> ( dat.page + & ifExists + (\page -> ("page", Just $ buildBytes naturalDecimalB page)) + ) + ) + ) + parser + redactedGetTorrentFile :: ( MonadLogger m, MonadThrow m, @@ -108,21 +165,143 @@ exampleSearch = do -- ("releasetype", "album"), ("order_by", "year") ] - pure (t1 >> t2 >> t3) + pure (t1 >> t2 >> t3 >> pure ()) --- | Do the search, return a transaction that inserts all results from all pages of the search. -redactedSearchAndInsert :: - forall m. +redactedRefreshArtist :: ( MonadLogger m, MonadPostgres m, MonadThrow m, MonadOtel m, - MonadRedacted m + MonadRedacted m, + HasField "artistId" dat Text ) => + dat -> + m (Transaction m (Label "newTorrents" [Label "torrentId" Int])) +redactedRefreshArtist dat = do + redactedPagedSearchAndInsert + (Json.key "torrentgroup" $ parseTourGroups (T2 (label @"torrentFieldName" "torrent") (label @"torrentIdName" "id"))) + ( \page -> + redactedGetArtist + ( T2 + (getLabel @"artistId" dat) + page + ) + ) + +-- | Do the search, return a transaction that inserts all results from all pages of the search. +redactedSearchAndInsert :: + (MonadLogger m, MonadPostgres m, MonadThrow m, MonadOtel m, MonadRedacted m) => [(ByteString, ByteString)] -> - m (Transaction m ()) -redactedSearchAndInsert extraArguments = do - logInfo [fmt|Doing redacted search with arguments: {showPretty extraArguments}|] + m (Transaction m (Label "newTorrents" [Label "torrentId" Int])) +redactedSearchAndInsert extraArguments = + redactedPagedSearchAndInsert + (Json.key "results" $ parseTourGroups (T2 (label @"torrentFieldName" "torrents") (label @"torrentIdName" "torrentId"))) + ( redactedSearch + (label @"actionArgs" extraArguments) + ) + +-- | Parse the standard Redacted reply object, @{ status: "success", response: ... }@ or throw an error. +-- +-- The response might contain a `pages` field, if not we’ll return 1. +parseRedactedReplyStatus :: + (Monad m) => + Json.ParseT ErrorTree m b -> + Json.ParseT ErrorTree m (T2 "pages" Natural "response" b) +parseRedactedReplyStatus inner = do + status <- Json.key "status" Json.asText + when (status /= "success") $ do + Json.throwCustomError ([fmt|Status was not "success", but {status}|] :: ErrorTree) + Json.key "response" $ do + pages <- + Json.keyMay + "pages" + ( Field.toJsonParser + ( Field.mapError singleError $ + Field.jsonNumber >>> Field.boundedScientificIntegral @Int "not an Integer" >>> Field.integralToNatural + ) + ) + -- in case the field is missing, let’s assume there is only one page + <&> fromMaybe 1 + res <- inner + pure $ + T2 + (label @"pages" pages) + (label @"response" res) + +type TourGroups = + ( Label + "tourGroups" + [ T2 + "tourGroup" + (T3 "groupId" Int "groupName" Text "fullJsonResult" Json.Value) + "torrents" + [T2 "torrentId" Int "fullJsonResult" Json.Value] + ] + ) + +parseTourGroups :: + ( Monad m, + HasField "torrentFieldName" opts Text, + HasField "torrentIdName" opts Text + ) => + opts -> + Json.ParseT err m TourGroups +parseTourGroups opts = + do + label @"tourGroups" + <$> ( catMaybes + <$> ( Json.eachInArray $ do + Json.keyMay opts.torrentFieldName (pure ()) >>= \case + -- not a torrent group, maybe some files or something (e.g. guitar tabs see Dream Theater Systematic Chaos) + Nothing -> pure Nothing + Just () -> do + groupId <- Json.keyLabel @"groupId" "groupId" (Json.asIntegral @_ @Int) + groupName <- Json.keyLabel @"groupName" "groupName" Json.asText + fullJsonResult <- + label @"fullJsonResult" + <$> ( Json.asObject + -- remove torrents cause they are inserted separately below + <&> KeyMap.filterWithKey (\k _ -> k /= (opts.torrentFieldName & Key.fromText)) + <&> Json.Object + ) + let tourGroup = T3 groupId groupName fullJsonResult + torrents <- Json.keyLabel @"torrents" opts.torrentFieldName $ + Json.eachInArray $ do + torrentId <- Json.keyLabel @"torrentId" opts.torrentIdName (Json.asIntegral @_ @Int) + fullJsonResultT <- + label @"fullJsonResult" + <$> ( Json.asObject + <&> KeyMap.mapKeyVal + ( \k -> + if + -- some torrent objects use “snatched” instead of “snatches” + | k == "snatched" -> "snatches" + -- normalize the torrent id field + | k == (opts.torrentIdName & Key.fromText) -> "torrentId" + | otherwise -> k + ) + id + <&> Json.Object + ) + pure $ T2 torrentId fullJsonResultT + pure $ Just (T2 (label @"tourGroup" tourGroup) torrents) + ) + ) + +redactedPagedSearchAndInsert :: + forall m. + ( MonadLogger m, + MonadPostgres m + ) => + Json.Parse ErrorTree TourGroups -> + -- | A redacted request that returns a paged result + ( forall a. + Label "page" (Maybe Natural) -> + Json.Parse ErrorTree a -> + m a + ) -> + m (Transaction m (Label "newTorrents" [Label "torrentId" Int])) +redactedPagedSearchAndInsert innerParser pagedRequest = do -- The first search returns the amount of pages, so we use that to query all results piece by piece. firstPage <- go Nothing let remainingPages = firstPage.pages - 1 @@ -131,58 +310,17 @@ redactedSearchAndInsert extraArguments = do otherPages <- traverse go (Just <$> otherPagesNum) pure $ (firstPage : otherPages) - & concatMap (.tourGroups) + & concatMap (.response.tourGroups) & \case - IsNonEmpty tgs -> tgs & insertTourGroupsAndTorrents - IsEmpty -> pure () + IsNonEmpty tgs -> do + tgs & insertTourGroupsAndTorrents + pure $ label @"newTorrents" (tgs & concatMap (\tg -> tg.torrents <&> getLabel @"torrentId")) + IsEmpty -> pure $ label @"newTorrents" [] where go mpage = - redactedSearch - ( extraArguments - -- pass the page (for every search but the first one) - <> (mpage & ifExists (\page -> ("page", buildBytes naturalDecimalB page))) - ) - ( do - status <- Json.key "status" Json.asText - when (status /= "success") $ do - Json.throwCustomError [fmt|Status was not "success", but {status}|] - Json.key "response" $ do - pages <- - Json.keyMay "pages" (Field.toJsonParser (Field.mapError singleError $ Field.jsonNumber >>> Field.boundedScientificIntegral @Int "not an Integer" >>> Field.integralToNatural)) - -- in case the field is missing, let’s assume there is only one page - <&> fromMaybe 1 - Json.key "results" $ do - tourGroups <- - label @"tourGroups" - <$> ( catMaybes - <$> ( Json.eachInArray $ do - Json.keyMay "torrents" (pure ()) >>= \case - -- not a torrent group, maybe some files or something (e.g. guitar tabs see Dream Theater Systematic Chaos) - Nothing -> pure Nothing - Just () -> do - groupId <- Json.keyLabel @"groupId" "groupId" (Json.asIntegral @_ @Int) - groupName <- Json.keyLabel @"groupName" "groupName" Json.asText - fullJsonResult <- - label @"fullJsonResult" - <$> ( Json.asObject - -- remove torrents cause they are inserted separately below - <&> KeyMap.filterWithKey (\k _ -> k /= "torrents") - <&> Json.Object - ) - let tourGroup = T3 groupId groupName fullJsonResult - torrents <- Json.keyLabel @"torrents" "torrents" $ - Json.eachInArray $ do - torrentId <- Json.keyLabel @"torrentId" "torrentId" (Json.asIntegral @_ @Int) - fullJsonResultT <- label @"fullJsonResult" <$> Json.asValue - pure $ T2 torrentId fullJsonResultT - pure $ Just (T2 (label @"tourGroup" tourGroup) torrents) - ) - ) - pure - ( T2 - (label @"pages" pages) - tourGroups - ) + pagedRequest + (label @"page" mpage) + ( parseRedactedReplyStatus $ innerParser ) insertTourGroupsAndTorrents :: NonEmpty @@ -238,11 +376,15 @@ redactedSearchAndInsert extraArguments = do full_json_result = excluded.full_json_result RETURNING (id) |] - ( dats <&> \dat -> - ( dat.groupId, - dat.groupName, - dat.fullJsonResult - ) + ( dats + -- make sure we don’t have the same conflict target twice + & NonEmpty.nubBy (\a b -> a.groupId == b.groupId) + <&> ( \dat -> + ( dat.groupId, + dat.groupName, + dat.fullJsonResult + ) + ) ) (label @"tourGroupIdPg" <$> Dec.fromField @Int) @@ -292,6 +434,7 @@ redactedSearchAndInsert extraArguments = do | dat <- dats, group <- dat.torrents ] + & List.nubBy (\a b -> a.torrentId == b.torrentId) & unzip3PGArray @"torrentGroupIdPg" @Int @@ -455,7 +598,8 @@ getTorrentById dat = do data GetBestTorrentsFilter = GetBestTorrentsFilter { onlyDownloaded :: Bool, - onlyArtist :: Maybe (Label "artistRedactedId" Natural) + onlyArtist :: Maybe (Label "artistRedactedId" Natural), + onlyTheseTorrents :: Maybe ([Label "torrentId" Int]) } -- | Find the best torrent for each torrent group (based on the seeding_weight) @@ -477,6 +621,9 @@ getBestTorrents opts = do -- filter by artist id AND (?::bool OR (to_jsonb(?::int) <@ (jsonb_path_query_array(full_json_result, '$.artists[*].id')))) + -- filter by torrent ids + AND + (?::bool OR torrent_id = ANY (?::int[])) ORDER BY torrent_group, -- prefer torrents which we already downloaded @@ -488,7 +635,12 @@ getBestTorrents opts = do t.torrent_id, t.seeding_weight, tg.full_json_result->>'releaseType' AS release_type, - t.full_json_result->'artists' AS artists, + -- TODO: different endpoints handle this differently (e.g. action=search and action=artist), we should unify this while parsing + COALESCE( + t.full_json_result->'artists', + tg.full_json_result->'artists', + '[]'::jsonb + ) as artists, tg.full_json_result->>'groupName' AS group_name, tg.full_json_result->>'groupYear' AS group_year, t.torrent_file IS NOT NULL AS has_torrent_file, @@ -503,9 +655,14 @@ getBestTorrents opts = do let (onlyArtistB, onlyArtistId) = case opts.onlyArtist of Nothing -> (True, 0) Just a -> (False, a.artistRedactedId) + let (onlyTheseTorrentsB, onlyTheseTorrents) = case opts.onlyTheseTorrents of + Nothing -> (True, PGArray []) + Just a -> (False, a <&> (.torrentId) & PGArray) ( opts.onlyDownloaded :: Bool, onlyArtistB :: Bool, - onlyArtistId & fromIntegral @Natural @Int + onlyArtistId & fromIntegral @Natural @Int, + onlyTheseTorrentsB :: Bool, + onlyTheseTorrents ) ) ( do @@ -610,12 +767,12 @@ redactedApiRequestJson span dat parser = do mkRedactedApiRequest dat >>= Http.httpJson defaults parser --- test :: (MonadThrow m, MonadRedacted m, MonadOtel m) => m () --- test = --- inSpan' "test" $ \span -> do --- redactedApiRequestJson --- span --- (T2 (label @"action" "browse") (label @"actionArgs" [("searchstr", Just "dream theater")])) --- (Json.asValue) --- <&> Pretty.showPrettyJson --- >>= liftIO . putStderrLn +test :: (MonadThrow m, MonadRedacted m, MonadOtel m) => m () +test = + inSpan' "test" $ \span -> do + redactedApiRequestJson + span + (T2 (label @"action" "artist") (label @"actionArgs" [("id", Just "2785")])) + (Json.asValue) + <&> Pretty.showPrettyJsonColored + >>= liftIO . putStderrLn diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs index 0d69ec437..f9824fbc7 100644 --- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs +++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs @@ -14,6 +14,7 @@ import Control.Monad.Reader import Data.Aeson qualified as Json import Data.Aeson.BetterErrors qualified as Json import Data.Aeson.KeyMap qualified as KeyMap +import Data.CaseInsensitive (CI) import Data.Error.Tree import Data.HashMap.Strict qualified as HashMap import Data.List qualified as List @@ -100,6 +101,9 @@ htmlUi = do Left (AppExceptionPretty err) -> do runInIO (logError (err & Pretty.prettyErrsNoColor & stringToText)) respondOrig (Wai.responseLBS Http.status500 [] "") + Left (AppExceptionEnc err) -> do + runInIO (logError (Enc.encToTextPrettyColored err)) + respondOrig (Wai.responseLBS Http.status500 [] "") catchAppException $ do let mp span parser = @@ -132,7 +136,27 @@ htmlUi = do ( do label @"searchstr" <$> Multipart.field "redacted-search" Cat.id ) - snipsRedactedSearch dat + t <- redactedSearchAndInsert [("searchstr", dat.searchstr)] + runTransaction $ do + res <- t + table <- + getBestTorrentsTable + (label @"groupByReleaseType" True) + ( Just (E21 (label @"onlyTheseTorrents" res.newTorrents)) :: + ( Maybe + ( E2 + "onlyTheseTorrents" + [Label "torrentId" Int] + "artistRedactedId" + Natural + ) + ) + ) + pure + [hsx| +

Search results for 
{dat.searchstr}

+ {table} + |] ), ( "snips/redacted/torrentDataJson", respond.html $ \span -> do @@ -226,6 +250,18 @@ htmlUi = do $ \qry _span -> do artistPage qry ), + ( "artist/refresh", + respond.htmlOrRedirect $ + \span -> do + dat <- + mp + span + (label @"artistId" <$> Multipart.field "artist-id" Field.utf8) + t <- redactedRefreshArtist dat + runTransaction $ do + t + pure $ E22 (label @"redirectTo" [fmt|/artist?redacted_id={dat.artistId}|]) + ), ( "autorefresh", respond.plain $ do qry <- @@ -264,7 +300,7 @@ htmlUi = do -- "https://musicbrainz.org/work/92000fd4-d304-406d-aeb4-6bdbeed318ec" -- ) -- <&> renderJsonld - bestTorrentsTable <- getBestTorrentsTable Nothing + bestTorrentsTable <- getBestTorrentsTable (label @"groupByReleaseType" False) Nothing -- transmissionTorrentsTable <- lift @Transaction getTransmissionTorrentsTable pure $ htmlPageChrome @@ -299,15 +335,23 @@ htmlUi = do -- | Reload the current page (via the Referer header) if the browser has Javascript disabled (and thus htmx does not work). This should make post requests work out of the box. htmxOrReferer :: Wai.Request -> Wai.Response -> Wai.Response -htmxOrReferer req act = do +htmxOrReferer req resp = do let fnd h = req & Wai.requestHeaders & List.find (\(hdr, _) -> hdr == h) let referer = fnd "Referer" if - | Just _ <- fnd "Hx-Request" -> act - | Nothing <- referer -> act + | Just _ <- fnd "Hx-Request" -> resp + | Nothing <- referer -> resp | Just (_, rfr) <- referer -> do Wai.responseLBS seeOther303 [("Location", rfr)] "" +-- | Redirect to the given page, if the browser has Javascript enabled use HTMX client side redirect, otherwise use a normal HTTP redirect. +redirectOrFallback :: ByteString -> (Status -> (CI ByteString, ByteString) -> Wai.Response) -> Wai.Request -> Wai.Response +redirectOrFallback target responseFn req = do + let fnd h = req & Wai.requestHeaders & List.find (\(hdr, _) -> hdr == h) + case fnd "Hx-Request" of + Just _ -> responseFn Http.ok200 ("Hx-Redirect", target) + Nothing -> responseFn Http.seeOther303 ("Location", target) + htmlPageChrome :: (ToHtml a) => Text -> a -> Html htmlPageChrome title body = Html.docTypeHtml $ @@ -352,9 +396,10 @@ artistPage :: artistPage dat = runTransaction $ do fresh <- getBestTorrentsData - (Just $ getLabel @"artistRedactedId" dat) + (Just $ E22 (getLabel @"artistRedactedId" dat)) let artistName = fresh & findMaybe (\t -> t.artists & findMaybe (\a -> if a.artistId == (dat.artistRedactedId & fromIntegral @Natural @Int) then Just a.artistName else Nothing)) let torrents = mkBestTorrentsTable (label @"groupByReleaseType" True) fresh + pure $ htmlPageChrome ( case artistName of @@ -362,9 +407,22 @@ artistPage dat = runTransaction $ do Just a -> [fmt|{a} - Artist Page - whatcd-resolver|] ) [hsx| - Artist ID: {dat.artistRedactedId} +

Artist ID: {dat.artistRedactedId}

- {torrents} +
+ {torrents} +
+ +
+ + +
Refreshing!
+
|] type Handlers m = HandlerResponses m -> Map Text (m ResponseReceived) @@ -372,6 +430,8 @@ type Handlers m = HandlerResponses m -> Map Text (m ResponseReceived) data HandlerResponses m = HandlerResponses { -- | render html html :: (Otel.Span -> m Html) -> m ResponseReceived, + -- | either render html or redirect to another page + htmlOrRedirect :: (Otel.Span -> m (E2 "respond" Html "redirectTo" ByteString)) -> m ResponseReceived, -- | render html after parsing some query arguments htmlWithQueryArgs :: forall a. (Parse Query a -> (a -> Otel.Span -> m Html) -> m ResponseReceived), -- | render html or reload the page via the Referer header if no htmx @@ -381,6 +441,7 @@ data HandlerResponses m = HandlerResponses } runHandlers :: + forall m. (MonadOtel m) => (HandlerResponses m -> m ResponseReceived) -> (HandlerResponses m -> Map Text (m ResponseReceived)) -> @@ -401,18 +462,26 @@ runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do } ) ( \span -> do - res <- act span <&> (\h -> T2 (label @"html" h) (label @"extraHeaders" [])) + res <- act span <&> (\h -> label @"html" h) addEventSimple span "Got Html result, rendering…" liftIO $ respond (resp res) ) - let htmlResp res = Wai.responseLBS Http.ok200 ([("Content-Type", "text/html")] <> res.extraHeaders) . Html.renderHtml $ res.html + let htmlResp res = Wai.responseLBS Http.ok200 ([("Content-Type", "text/html")]) . Html.renderHtml $ res.html let html = html' htmlResp let htmlOrReferer = html' $ \res -> htmxOrReferer req (htmlResp res) - + let htmlOrRedirect :: (Otel.Span -> m (E2 "respond" Html "redirectTo" ByteString)) -> m ResponseReceived + htmlOrRedirect = html' $ \res -> case res.html of + E21 h -> htmlResp (label @"html" h.respond) + E22 r -> + redirectOrFallback + r.redirectTo + (\status header -> Wai.responseLBS status [header] "") + req let handlerResponses = ( HandlerResponses { plain = (\m -> liftIO $ runInIO m >>= respond), html, + htmlOrRedirect, htmlWithQueryArgs = \parser act -> case req & Parse.runParse "Unable to find the right request query arguments" (lmap Wai.queryString parser) of Right a -> html (act a) @@ -513,26 +582,6 @@ checkException some = case fromException some of Nothing -> Left some Just e -> Right e -snipsRedactedSearch :: - ( MonadLogger m, - MonadPostgres m, - HasField "searchstr" r ByteString, - MonadThrow m, - MonadTransmission m, - MonadOtel m, - MonadRedacted m - ) => - r -> - m Html -snipsRedactedSearch dat = do - t <- - redactedSearchAndInsert - [ ("searchstr", dat.searchstr) - ] - runTransaction $ do - t - getBestTorrentsTable (Nothing :: Maybe (Label "artistRedactedId" Natural)) - data ArtistFilter = ArtistFilter { onlyArtist :: Maybe (Label "artistId" Text) } @@ -542,13 +591,15 @@ getBestTorrentsTable :: MonadThrow m, MonadLogger m, MonadPostgres m, - MonadOtel m + MonadOtel m, + HasField "groupByReleaseType" opts Bool ) => - Maybe (Label "artistRedactedId" Natural) -> + opts -> + Maybe (E2 "onlyTheseTorrents" [Label "torrentId" Int] "artistRedactedId" Natural) -> Transaction m Html -getBestTorrentsTable dat = do +getBestTorrentsTable opts dat = do fresh <- getBestTorrentsData dat - pure $ mkBestTorrentsTable (label @"groupByReleaseType" False) fresh + pure $ mkBestTorrentsTable opts fresh doIfJust :: (Applicative f) => (a -> f ()) -> Maybe a -> f () doIfJust = traverse_ @@ -560,11 +611,15 @@ getBestTorrentsData :: MonadPostgres m, MonadOtel m ) => - Maybe (Label "artistRedactedId" Natural) -> + Maybe (E2 "onlyTheseTorrents" [Label "torrentId" Int] "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, naturalDecimalT)) - let getBest = getBestTorrents GetBestTorrentsFilter {onlyArtist = artistFilter, onlyDownloaded = False} +getBestTorrentsData filters = inSpan' "get torrents table data" $ \span -> do + let onlyArtist = label @"artistRedactedId" <$> (filters >>= getE22 @"artistRedactedId") + onlyArtist & doIfJust (\a -> addAttribute span "artist-filter.redacted-id" (a.artistRedactedId, naturalDecimalT)) + let onlyTheseTorrents = filters >>= getE21 @"onlyTheseTorrents" + onlyTheseTorrents & doIfJust (\a -> addAttribute span "torrent-filter.ids" (a <&> (getLabel @"torrentId") & showToText & Otel.toAttribute)) + + let getBest = getBestTorrents GetBestTorrentsFilter {onlyDownloaded = False, ..} bestStale :: [TorrentData ()] <- getBest (statusInfo, transmissionStatus) <- getAndUpdateTransmissionTorrentsStatus @@ -589,7 +644,16 @@ getBestTorrentsData artistFilter = inSpan' "get torrents table data" $ \span -> else pure bestStale pure $ bestBest - & filter (\td -> td.releaseType /= releaseTypeCompilation) + -- filter out some kinds we don’t really care about + & filter + ( \td -> + td.releaseType + `List.notElem` [ releaseTypeCompilation, + releaseTypeDJMix, + releaseTypeMixtape, + releaseTypeRemix + ] + ) -- we have to update the status of every torrent that’s not in tranmission anymore -- TODO I feel like it’s easier (& more correct?) to just do the database request again … <&> ( \td -> case td.torrentStatus of @@ -603,7 +667,11 @@ getBestTorrentsData artistFilter = inSpan' "get torrents table data" $ \span -> NoTorrentFileYet -> td {torrentStatus = NoTorrentFileYet} ) -mkBestTorrentsTable :: Label "groupByReleaseType" Bool -> [TorrentData (Label "percentDone" Percentage)] -> Html +mkBestTorrentsTable :: + (HasField "groupByReleaseType" opts Bool) => + opts -> + [TorrentData (Label "percentDone" Percentage)] -> + Html mkBestTorrentsTable opts fresh = do let localTorrent b = case b.torrentStatus of NoTorrentFileYet -> @@ -806,7 +874,7 @@ migrate = inSpan "Database Migration" $ do $$ LANGUAGE plpgsql IMMUTABLE; ALTER TABLE redacted.torrents_json - ADD COLUMN IF NOT EXISTS seeding_weight int GENERATED ALWAYS AS (calc_seeding_weight(full_json_result)) STORED; + ADD COLUMN IF NOT EXISTS seeding_weight int NOT NULL GENERATED ALWAYS AS (calc_seeding_weight(full_json_result)) STORED; -- inflect out values of the full json CREATE OR REPLACE VIEW redacted.torrents AS @@ -862,6 +930,7 @@ runAppWith appT = withTracer $ \tracer -> withDb $ \db -> do `catch` ( \case AppExceptionPretty p -> throwM $ EscapedException (p & Pretty.prettyErrs) AppExceptionTree t -> throwM $ EscapedException (t & prettyErrorTree & textToString) + AppExceptionEnc e -> throwM $ EscapedException (e & Enc.encToTextPrettyColored & textToString) ) -- | Just a silly wrapper so that correctly format any 'AppException' that would escape the runAppWith scope.