diff --git a/users/Profpatsch/my-prelude/default.nix b/users/Profpatsch/my-prelude/default.nix index a851fdcb0..520ed6185 100644 --- a/users/Profpatsch/my-prelude/default.nix +++ b/users/Profpatsch/my-prelude/default.nix @@ -7,6 +7,7 @@ pkgs.haskellPackages.mkDerivation { src = depot.users.Profpatsch.exactSource ./. [ ./my-prelude.cabal ./src/Aeson.hs + ./src/Comparison.hs ./src/Json.hs ./src/Json/Enc.hs ./src/Arg.hs diff --git a/users/Profpatsch/my-prelude/my-prelude.cabal b/users/Profpatsch/my-prelude/my-prelude.cabal index ba64f1c3f..854390395 100644 --- a/users/Profpatsch/my-prelude/my-prelude.cabal +++ b/users/Profpatsch/my-prelude/my-prelude.cabal @@ -61,6 +61,7 @@ library Aeson Arg AtLeast + Comparison Json Json.Enc Test diff --git a/users/Profpatsch/my-prelude/src/Comparison.hs b/users/Profpatsch/my-prelude/src/Comparison.hs new file mode 100644 index 000000000..4ad38f746 --- /dev/null +++ b/users/Profpatsch/my-prelude/src/Comparison.hs @@ -0,0 +1,61 @@ +-- | Helper module for working better with 'Comparison' contravariants. +module Comparison + ( module Data.Functor.Contravariant, + Comparison (..), + defaultComparison1, + down, + down1, + maybeDown, + groupAllWithComparison, + listIndexComparison, + ) +where + +import Data.Functor.Classes +import Data.Functor.Contravariant +import Data.List qualified as List +import Data.List.NonEmpty +import Data.List.NonEmpty qualified as NonEmpty + +-- | Unlift an Ord1 to a `Comparison` function. Analogous to `defaultComparison`. +defaultComparison1 :: (Ord1 f) => Comparison a -> Comparison (f a) +defaultComparison1 = Comparison . liftCompare . getComparison + +-- | Invert the ordering of the comparison +down :: Comparison a -> Comparison a +down c = Comparison $ \a b -> case getComparison c a b of + LT -> GT + EQ -> EQ + GT -> LT + +-- | Invert the ordering of the outer comparison function but not the inner one +-- +-- Can be used to e.g. change the ordering of `Maybe` values, but not the ordering of the inner values. +-- Example: +-- +-- > maybeDown = down1 (defaultComparison1 @Maybe) +-- > maybeDown (Just 1) (Just 2) == LT +-- > maybeDown (Just 1) Nothing == LT +-- > maybeDown Nothing (Just 2) == GT +down1 :: (Comparison a -> Comparison b) -> Comparison a -> Comparison b +down1 inner = down . inner . down + +-- | Sort every Nothing behind every Just +maybeDown :: Comparison a -> Comparison (Maybe a) +maybeDown = down1 (defaultComparison1 @Maybe) + +-- | Group all items in the list that are equal according to the comparison function. Sort the list first so every equivalence class has at most one list in the output. +groupAllWithComparison :: Comparison a -> [a] -> [NonEmpty a] +groupAllWithComparison c xs = + NonEmpty.groupBy + (getEquivalence $ comparisonEquivalence c) + $ List.sortBy (getComparison c) xs + +-- | Everything in the list is ordered in the order of equality in the list. +-- +-- Any item is not in the list is automatically GT to every item in the list, +-- and EQ to every item not in the list. +listIndexComparison :: (Eq a) => [a] -> Comparison a +listIndexComparison xs = + (\x -> List.elemIndex x xs) + >$< maybeDown (defaultComparison @Int) diff --git a/users/Profpatsch/whatcd-resolver/src/Redacted.hs b/users/Profpatsch/whatcd-resolver/src/Redacted.hs index 3cf547999..209b8eae1 100644 --- a/users/Profpatsch/whatcd-resolver/src/Redacted.hs +++ b/users/Profpatsch/whatcd-resolver/src/Redacted.hs @@ -4,6 +4,7 @@ module Redacted where import AppT import Arg +import Comparison import Control.Monad.Logger.CallStack import Control.Monad.Reader import Data.Aeson qualified as Json @@ -365,6 +366,7 @@ assertOneUpdated span name x = case x.numberOfRowsAffected of data TorrentData transmissionInfo = TorrentData { groupId :: Int, torrentId :: Int, + releaseType :: ReleaseType, seedingWeight :: Int, artists :: [T2 "artistId" Int "artistName" Text], torrentGroupJson :: TorrentGroupJson, @@ -372,6 +374,34 @@ data TorrentData transmissionInfo = TorrentData torrentFormat :: Text } +-- | https://redacted.sh/wiki.php?action=article&id=455#_1804298149 +newtype ReleaseType = ReleaseType {unReleaseType :: Text} + deriving stock (Eq, Show) + +releaseTypeComparison :: Comparison ReleaseType +releaseTypeComparison = listIndexComparison [releaseTypeAlbum, releaseTypeSoundtrack, releaseTypeEP, releaseTypeAnthology, releaseTypeCompilation, releaseTypeSingle, releaseTypeLiveAlbum, releaseTypeRemix, releaseTypeBootleg, releaseTypeInterview, releaseTypeMixtape, releaseTypeDemo, releaseTypeConcertRecording, releaseTypeDJMix, releaseTypeUnknown, releaseTypeProducedBy, releaseTypeComposition, releaseTypeRemixedBy, releaseTypeGuestAppearance] + +releaseTypeAlbum, releaseTypeSoundtrack, releaseTypeEP, releaseTypeAnthology, releaseTypeCompilation, releaseTypeSingle, releaseTypeLiveAlbum, releaseTypeRemix, releaseTypeBootleg, releaseTypeInterview, releaseTypeMixtape, releaseTypeDemo, releaseTypeConcertRecording, releaseTypeDJMix, releaseTypeUnknown, releaseTypeProducedBy, releaseTypeComposition, releaseTypeRemixedBy, releaseTypeGuestAppearance :: ReleaseType +releaseTypeAlbum = ReleaseType "Album" +releaseTypeSoundtrack = ReleaseType "Soundtrack" +releaseTypeEP = ReleaseType "EP" +releaseTypeAnthology = ReleaseType "Anthology" +releaseTypeCompilation = ReleaseType "Compilation" +releaseTypeSingle = ReleaseType "Single" +releaseTypeLiveAlbum = ReleaseType "Live album" +releaseTypeRemix = ReleaseType "Remix" +releaseTypeBootleg = ReleaseType "Bootleg" +releaseTypeInterview = ReleaseType "Interview" +releaseTypeMixtape = ReleaseType "Mixtape" +releaseTypeDemo = ReleaseType "Demo" +releaseTypeConcertRecording = ReleaseType "Concert Recording" +releaseTypeDJMix = ReleaseType "DJ Mix" +releaseTypeUnknown = ReleaseType "Unknown" +releaseTypeProducedBy = ReleaseType "Produced By" +releaseTypeComposition = ReleaseType "Composition" +releaseTypeRemixedBy = ReleaseType "Remixed By" +releaseTypeGuestAppearance = ReleaseType "Guest Appearance" + data TorrentGroupJson = TorrentGroupJson { groupName :: Text, groupYear :: Natural @@ -427,6 +457,7 @@ getBestTorrents opts = do tg.group_id, t.torrent_id, t.seeding_weight, + tg.full_json_result->>'releaseType' AS release_type, t.full_json_result->'artists' AS artists, tg.full_json_result->>'groupName' AS group_name, tg.full_json_result->>'groupYear' AS group_year, @@ -451,6 +482,7 @@ getBestTorrents opts = do groupId <- Dec.fromField @Int torrentId <- Dec.fromField @Int seedingWeight <- Dec.fromField @Int + releaseType <- ReleaseType <$> Dec.text artists <- Dec.json $ Json.eachInArray $ do id_ <- Json.keyLabel @"artistId" "id" (Json.asIntegral @_ @Int) diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs index c8850e70a..c5c763226 100644 --- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs +++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs @@ -5,6 +5,7 @@ module WhatcdResolver where import AppT import Arg +import Comparison import Control.Category qualified as Cat import Control.Monad.Catch.Pure (runCatch) import Control.Monad.Logger.CallStack @@ -15,6 +16,7 @@ import Data.Aeson.KeyMap qualified as KeyMap import Data.Error.Tree import Data.HashMap.Strict qualified as HashMap import Data.List qualified as List +import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict qualified as Map import Data.Pool qualified as Pool import Data.Text qualified as Text @@ -347,9 +349,11 @@ artistPage :: dat -> m Html artistPage dat = runTransaction $ do - fresh <- getBestTorrentsData (Just $ getLabel @"artistRedactedId" dat) + fresh <- + getBestTorrentsData + (Just $ 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 fresh + let torrents = mkBestTorrentsTable (label @"groupByReleaseType" True) fresh pure $ htmlPageChrome ( case artistName of @@ -522,8 +526,7 @@ snipsRedactedSearch :: snipsRedactedSearch dat = do t <- redactedSearchAndInsert - [ ("searchstr", dat.searchstr), - ("releasetype", "album") + [ ("searchstr", dat.searchstr) ] runTransaction $ do t @@ -544,7 +547,7 @@ getBestTorrentsTable :: Transaction m Html getBestTorrentsTable dat = do fresh <- getBestTorrentsData dat - pure $ mkBestTorrentsTable fresh + pure $ mkBestTorrentsTable (label @"groupByReleaseType" False) fresh doIfJust :: (Applicative f) => (a -> f ()) -> Maybe a -> f () doIfJust = traverse_ @@ -585,6 +588,7 @@ getBestTorrentsData artistFilter = inSpan' "get torrents table data" $ \span -> else pure bestStale pure $ bestBest + & filter (\td -> td.releaseType /= releaseTypeCompilation) -- 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 @@ -598,8 +602,8 @@ getBestTorrentsData artistFilter = inSpan' "get torrents table data" $ \span -> NoTorrentFileYet -> td {torrentStatus = NoTorrentFileYet} ) -mkBestTorrentsTable :: [TorrentData (Label "percentDone" Percentage)] -> Html -mkBestTorrentsTable fresh = do +mkBestTorrentsTable :: Label "groupByReleaseType" Bool -> [TorrentData (Label "percentDone" Percentage)] -> Html +mkBestTorrentsTable opts fresh = do let localTorrent b = case b.torrentStatus of NoTorrentFileYet -> [hsx| @@ -614,8 +618,8 @@ mkBestTorrentsTable fresh = do |] InTransmission info -> [hsx|{info.transmissionInfo.percentDone.unPercentage}% done|] NotInTransmissionYet -> [hsx||] - let bestRows = - fresh + let bestRows rowData = + rowData & foldMap ( \b -> do let artists = @@ -639,6 +643,7 @@ mkBestTorrentsTable fresh = do {Html.toHtml @Text b.torrentGroupJson.groupName} +
| Group ID | Artist | Name | +Type | Year | Weight | Format | @@ -661,11 +670,23 @@ mkBestTorrentsTable fresh = do
|---|