feat(users/Profpatsch/whatcd-resolver): implement artist refresh v0

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 <mail@profpatsch.de>

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)

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 :: Json.Value -> Json.ParseError ErrorTree -> T2 "errorMessage" Enc "valueAtErrorPath" (Maybe Json.Value)
-parseErrorTreeValCtx contextMsg origValue errs = do
+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
+  T2
-        & Json.displayError prettyErrorTree
+    ( label @"errorMessage" $
-        & Text.intercalate "\n"
+        errs
-        & newError
+          & displayErrorCustom
-    )
-      :| ( maybe
-             []
-             ( \ctx ->
-                 [ go origValue ctx
-                     & Pretty.showPrettyJson
-                     & newError
-                 ]
     )
+    ( 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
+  where
-    --
+    restriction =
-    -- @
+      RestrictJsonOpts
-    -- contextMsg
+        { maxDepth = 2,
-    -- \|
+          maxSizeObject = 10,
-    -- `- At the path: ["foo"]["bar"]
+          maxSizeArray = 3,
-    --   Type mismatch:
+          maxStringLength = 100
-    --   Expected a value of type object
+        }
-    --   Got: true
+    displayErrorCustom :: Json.ParseError ErrorTree -> Enc
-    -- @
+    displayErrorCustom = \case
-    & errorTree contextMsg
+      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 >$< ("<object {" <> 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
+                            "<some fields elided>"
+                            (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

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 =
+encToTextPretty enc' =
-  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 =
+encToTextPrettyLazy enc' =
-  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_

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

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
 

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

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
+          let err = Json.parseErrorTreeValCtx val e
-          appThrow span (AppExceptionTree prettyErr)
+          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

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,17 +39,72 @@ instance (MonadIO m) => MonadRedacted (AppT m) where
   getRedactedApiKey = AppT (asks (.redactedApiKey))
 
 redactedSearch ::
-  (MonadThrow m, MonadOtel m, MonadRedacted m) =>
+  ( MonadThrow m,
-  [(ByteString, ByteString)] ->
+    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 ->
+    redactedPagedRequest
+      span
+      ( T3
+          (label @"action" "browse")
+          (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" "browse")
+        (label @"action" dat.action)
-          (label @"actionArgs" ((advanced <&> second Just)))
+        ( label @"actionArgs" $
+            (dat.actionArgs <&> second Just)
+              <> ( dat.page
+                     & ifExists
+                       (\page -> ("page", Just $ buildBytes naturalDecimalB page))
+                 )
+        )
     )
     parser
 
@@ -108,55 +165,93 @@ 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.
+redactedRefreshArtist ::
-redactedSearchAndInsert ::
-  forall m.
   ( MonadLogger m,
     MonadPostgres m,
     MonadThrow m,
     MonadOtel m,
-    MonadRedacted m
+    MonadRedacted m,
+    HasField "artistId" dat Text
   ) =>
-  [(ByteString, ByteString)] ->
+  dat ->
-  m (Transaction m ())
+  m (Transaction m (Label "newTorrents" [Label "torrentId" Int]))
-redactedSearchAndInsert extraArguments = do
+redactedRefreshArtist dat = do
-  logInfo [fmt|Doing redacted search with arguments: {showPretty extraArguments}|]
+  redactedPagedSearchAndInsert
-  -- The first search returns the amount of pages, so we use that to query all results piece by piece.
+    (Json.key "torrentgroup" $ parseTourGroups (T2 (label @"torrentFieldName" "torrent") (label @"torrentIdName" "id")))
-  firstPage <- go Nothing
+    ( \page ->
-  let remainingPages = firstPage.pages - 1
+        redactedGetArtist
-  logInfo [fmt|Got the first page, found {remainingPages} more pages|]
+          ( T2
-  let otherPagesNum = [(2 :: Natural) .. remainingPages]
+              (getLabel @"artistId" dat)
-  otherPages <- traverse go (Just <$> otherPagesNum)
+              page
-  pure $
-    (firstPage : otherPages)
-      & concatMap (.tourGroups)
-      & \case
-        IsNonEmpty tgs -> tgs & insertTourGroupsAndTorrents
-        IsEmpty -> pure ()
-  where
-    go mpage =
-      redactedSearch
-        ( extraArguments
-            -- pass the page (for every search but the first one)
-            <> (mpage & ifExists (\page -> ("page", buildBytes naturalDecimalB page)))
           )
-        ( do
+    )
+
+-- | 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 (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}|]
+    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))
+      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
+    res <- inner
-                tourGroups <-
+    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 "torrents" (pure ()) >>= \case
+                    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
@@ -166,23 +261,66 @@ redactedSearchAndInsert extraArguments = do
                           label @"fullJsonResult"
                             <$> ( Json.asObject
                                     -- remove torrents cause they are inserted separately below
-                                                    <&> KeyMap.filterWithKey (\k _ -> k /= "torrents")
+                                    <&> KeyMap.filterWithKey (\k _ -> k /= (opts.torrentFieldName & Key.fromText))
                                     <&> Json.Object
                                 )
                         let tourGroup = T3 groupId groupName fullJsonResult
-                                        torrents <- Json.keyLabel @"torrents" "torrents" $
+                        torrents <- Json.keyLabel @"torrents" opts.torrentFieldName $
                           Json.eachInArray $ do
-                                            torrentId <- Json.keyLabel @"torrentId" "torrentId" (Json.asIntegral @_ @Int)
+                            torrentId <- Json.keyLabel @"torrentId" opts.torrentIdName (Json.asIntegral @_ @Int)
-                                            fullJsonResultT <- label @"fullJsonResult" <$> Json.asValue
+                            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)
                 )
         )
-                pure
+
-                  ( T2
+redactedPagedSearchAndInsert ::
-                      (label @"pages" pages)
+  forall m.
-                      tourGroups
+  ( 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
+  logInfo [fmt|Got the first page, found {remainingPages} more pages|]
+  let otherPagesNum = [(2 :: Natural) .. remainingPages]
+  otherPages <- traverse go (Just <$> otherPagesNum)
+  pure $
+    (firstPage : otherPages)
+      & concatMap (.response.tourGroups)
+      & \case
+        IsNonEmpty tgs -> do
+          tgs & insertTourGroupsAndTorrents
+          pure $ label @"newTorrents" (tgs & concatMap (\tg -> tg.torrents <&> getLabel @"torrentId"))
+        IsEmpty -> pure $ label @"newTorrents" []
+  where
+    go mpage =
+      pagedRequest
+        (label @"page" mpage)
+        ( parseRedactedReplyStatus $ innerParser
         )
     insertTourGroupsAndTorrents ::
       NonEmpty
@@ -238,12 +376,16 @@ redactedSearchAndInsert extraArguments = do
                 full_json_result = excluded.full_json_result
               RETURNING (id)
             |]
-        ( dats <&> \dat ->
+        ( 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)
 
     insertTorrents ::
@@ -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 :: (MonadThrow m, MonadRedacted m, MonadOtel m) => m ()
--- test =
+test =
---   inSpan' "test" $ \span -> do
+  inSpan' "test" $ \span -> do
---     redactedApiRequestJson
+    redactedApiRequestJson
---       span
+      span
---       (T2 (label @"action" "browse") (label @"actionArgs" [("searchstr", Just "dream theater")]))
+      (T2 (label @"action" "artist") (label @"actionArgs" [("id", Just "2785")]))
---       (Json.asValue)
+      (Json.asValue)
---       <&> Pretty.showPrettyJson
+      <&> Pretty.showPrettyJsonColored
---       >>= liftIO . putStderrLn
+      >>= liftIO . putStderrLn

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|
+                          <h1>Search results for <pre>{dat.searchstr}</pre></h1>
+                          {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
+    | Just _ <- fnd "Hx-Request" -> resp
-    | Nothing <- referer -> act
+    | 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}
+        <p>Artist ID: {dat.artistRedactedId}</p>
 
+        <div id="artist-torrents">
           {torrents}
+        </div>
+
+        <form method="post" action="artist/refresh" hx-post="artist/refresh">
+          <input
+            hidden
+            type="text"
+            name="artist-id"
+            value={dat.artistRedactedId & buildText naturalDecimalT}
+            />
+          <button type="submit" hx-disabled-elt="this">Refresh Artist Page</button>
+          <div class="htmx-indicator">Refreshing!</div>
+        </form>
       |]
 
 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
+getBestTorrentsData filters = inSpan' "get torrents table data" $ \span -> do
-  artistFilter & doIfJust (\a -> addAttribute span "artist-filter.redacted-id" (a.artistRedactedId, naturalDecimalT))
+  let onlyArtist = label @"artistRedactedId" <$> (filters >>= getE22 @"artistRedactedId")
-  let getBest = getBestTorrents GetBestTorrentsFilter {onlyArtist = artistFilter, onlyDownloaded = False}
+  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.