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>
2025-01-06 17:21:12 +01:00 · 2025-01-06 17:21:12 +01:00 · 3040fe2e90
commit 3040fe2e90
parent cabb8cd3d0
9 changed files with 584 additions and 163 deletions
--- 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)
--- 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 >$< ("<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
--- 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_
--- 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
--- 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