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>
This commit is contained in:
Profpatsch
parent
cabb8cd3d0
commit
3040fe2e90
9 changed files with 584 additions and 163 deletions
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
)
|
||||
:| ( maybe
|
||||
[]
|
||||
( \ctx ->
|
||||
[ go origValue ctx
|
||||
& Pretty.showPrettyJson
|
||||
& newError
|
||||
]
|
||||
T2
|
||||
( label @"errorMessage" $
|
||||
errs
|
||||
& displayErrorCustom
|
||||
)
|
||||
( 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
|
||||
|
|
|
|||
|
|
@ -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_
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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) =>
|
||||
[(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 ->
|
||||
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 @"actionArgs" ((advanced <&> second Just)))
|
||||
(label @"action" dat.action)
|
||||
( 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.
|
||||
redactedSearchAndInsert ::
|
||||
forall m.
|
||||
redactedRefreshArtist ::
|
||||
( MonadLogger m,
|
||||
MonadPostgres m,
|
||||
MonadThrow m,
|
||||
MonadOtel m,
|
||||
MonadRedacted m
|
||||
MonadRedacted m,
|
||||
HasField "artistId" dat Text
|
||||
) =>
|
||||
[(ByteString, ByteString)] ->
|
||||
m (Transaction m ())
|
||||
redactedSearchAndInsert extraArguments = do
|
||||
logInfo [fmt|Doing redacted search with arguments: {showPretty extraArguments}|]
|
||||
-- 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 (.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)))
|
||||
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
|
||||
)
|
||||
|
||||
-- | 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
|
||||
tourGroups <-
|
||||
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 "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)
|
||||
fullJsonResultT <- label @"fullJsonResult" <$> Json.asValue
|
||||
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)
|
||||
)
|
||||
)
|
||||
pure
|
||||
( T2
|
||||
(label @"pages" pages)
|
||||
tourGroups
|
||||
)
|
||||
|
||||
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
|
||||
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 =
|
||||
-- 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
| 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}
|
||||
<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
|
||||
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.
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue