feat(users/Profpatsch/whatcd-resolver): allow more than albums

When searching for an artist, we only put albums before, but now let’s
fetch all releases and group them by release type.

I group & sort on the backend instead of the database, cause it’s a
lot easier to express in Haskell code and the amount of data stays the
same (except for the filter for singles which I might move into the
SQL at one point?)

Adds a prelude module for better dealing with comparisons.

Change-Id: Iff235af611b6e1bac71b118a8a04fc73cacd169f
Reviewed-on: https://cl.tvl.fyi/c/depot/+/12951
Reviewed-by: Profpatsch <mail@profpatsch.de>
Tested-by: BuildkiteCI

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

users/Profpatsch/my-prelude/my-prelude.cabal

@@ -61,6 +61,7 @@ library
       Aeson
       Arg
       AtLeast
+      Comparison
       Json
       Json.Enc
       Test

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)

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)

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),
+      [ ("searchstr", dat.searchstr)
-        ("releasetype", "album")
       ]
   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 :: Label "groupByReleaseType" Bool -> [TorrentData (Label "percentDone" Percentage)] -> Html
-mkBestTorrentsTable fresh = do
+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|<button hx-post="snips/redacted/startTorrentFile" hx-swap="outerHTML" hx-vals={Enc.encToBytesUtf8 $ Enc.object [("torrent-id", Enc.int b.torrentId)]}>Start Torrent</button>|]
-  let bestRows =
+  let bestRows rowData =
-        fresh
+        rowData
           & foldMap
             ( \b -> do
                 let artists =
@@ -639,6 +643,7 @@ mkBestTorrentsTable fresh = do
                       {Html.toHtml @Text b.torrentGroupJson.groupName}
                     </a>
                   </td>
+                  <td>{Html.toHtml @Text b.releaseType.unReleaseType}</td>
                   <td>{Html.toHtml @Natural b.torrentGroupJson.groupYear}</td>
                   <td>{Html.toHtml @Int b.seedingWeight}</td>
                   <td>{Html.toHtml @Text b.torrentFormat}</td>
@@ -646,7 +651,10 @@ mkBestTorrentsTable fresh = do
                   </tr>
                 |]
             )
-  [hsx|
+  let section rows = do
+        let releaseType = rows & NonEmpty.head & (.releaseType.unReleaseType)
+        [hsx|
+        <h2>{releaseType}s</h2>
         <table class="table">
           <thead>
             <tr>
@@ -654,6 +662,7 @@ mkBestTorrentsTable fresh = do
               <th>Group ID</th>
               <th>Artist</th>
               <th>Name</th>
+              <th>Type</th>
               <th>Year</th>
               <th>Weight</th>
               <th>Format</th>
@@ -661,11 +670,23 @@ mkBestTorrentsTable fresh = do
             </tr>
           </thead>
           <tbody>
-            {bestRows}
+            {bestRows rows}
           </tbody>
         </table>
       |]
 
+  case fresh & nonEmpty of
+    Nothing -> [hsx|No torrents found|]
+    Just fresh' -> do
+      ( if opts.groupByReleaseType
+          then
+            fresh'
+              & toList
+              & groupAllWithComparison ((.releaseType) >$< releaseTypeComparison)
+          else [fresh']
+        )
+        & foldMap section
+
 mkLinkList :: [T2 "url" Text "content" Html] -> Html
 mkLinkList xs =
   xs