commit c619230f595b49d7679f2d27636a1e4bc3383416
parent e07c9c839b8d13395caa9dd4cb3b98d94a7a7159
Author: mtmn <miro@haravara.org>
Date: Sat, 11 Apr 2026 19:48:36 +0200
feat: zoom on hover for covers, bugfixes
Diffstat:
3 files changed, 166 insertions(+), 11 deletions(-)
diff --git a/src/Client.purs b/src/Client.purs
@@ -50,6 +50,7 @@ type State =
, loading :: Boolean
, currentTime :: Maybe Milliseconds
, failedCovers :: Set String
+ , hoveredCover :: Maybe String
, offset :: Int
, limit :: Int
, activeTab :: Tab
@@ -67,6 +68,8 @@ data Action
| SwitchTab Tab
| FilterBy String String
| ClearFilter
+ | HoverCover String
+ | UnhoverCover
component :: forall query input output m. MonadAff m => H.Component query input output m
component =
@@ -87,6 +90,7 @@ component =
, loading: true
, currentTime: Nothing
, failedCovers: Set.empty
+ , hoveredCover: Nothing
, offset: 0
, limit: 25
, activeTab: ListensTab
@@ -253,6 +257,8 @@ component =
, HP.src coverUrl
, HP.alt release
, HE.onError \_ -> ImageError coverUrl
+ , HE.onMouseEnter \_ -> HoverCover coverUrl
+ , HE.onMouseLeave \_ -> UnhoverCover
]
, case track.genre of
Just g -> HH.div [ HP.class_ (H.ClassName "genre-tag") ] [ HH.text g ]
@@ -315,6 +321,10 @@ component =
H.modify_ \state -> state { offset = max 0 (state.offset - state.limit) }
updateUrl
handleAction Refresh
+ HoverCover url -> do
+ H.modify_ _ { hoveredCover = Just url }
+ UnhoverCover -> do
+ H.modify_ _ { hoveredCover = Nothing }
updateUrl = do
state <- H.get
diff --git a/src/Db.purs b/src/Db.purs
@@ -6,7 +6,7 @@ import Data.Argonaut.Core (Json, toObject, toString)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..), fromMaybe)
import Effect (Effect)
-import Effect.Aff (Aff, makeAff, nonCanceler)
+import Effect.Aff (Aff, makeAff, nonCanceler, try)
import Effect.Exception (Error, error)
import Foreign (Foreign)
import Unsafe.Coerce (unsafeCoerce)
@@ -14,7 +14,7 @@ import Types (Listen(..), TrackMetadata(..), MbidMapping(..), Stats(..), StatsEn
import Data.Traversable (traverse)
import Foreign.Object as Object
import Data.Nullable (Nullable, toMaybe, toNullable)
-import Data.Array (mapMaybe)
+import Data.Array (mapMaybe, uncons)
foreign import data Connection :: Type
@@ -104,7 +104,10 @@ getScrobbles conn limit offset (Just { field, value }) = do
initReleaseMetadata :: Connection -> Aff Unit
initReleaseMetadata conn = do
- run conn "CREATE TABLE IF NOT EXISTS release_metadata (release_mbid VARCHAR PRIMARY KEY, genre VARCHAR, label VARCHAR, release_year INTEGER)" []
+ _ <- run conn "CREATE TABLE IF NOT EXISTS release_metadata (release_mbid VARCHAR PRIMARY KEY, genre VARCHAR, label VARCHAR, release_year INTEGER, genre_checked_at INTEGER)" []
+ -- Migration for existing databases; SQLite errors if column already exists, so ignore the failure
+ _ <- try $ run conn "ALTER TABLE release_metadata ADD COLUMN genre_checked_at INTEGER" []
+ pure unit
getUnenrichedMbids :: Connection -> Int -> Aff (Array String)
getUnenrichedMbids conn limit = do
@@ -117,10 +120,21 @@ getUnenrichedMbids conn limit = do
obj <- toObject json
Object.lookup "release_mbid" obj >>= toString
+getEmptyGenreMbids :: Connection -> Int -> Aff (Array String)
+getEmptyGenreMbids conn limit = do
+ rows <- queryAll conn
+ "SELECT DISTINCT s.release_mbid FROM scrobbles s JOIN release_metadata rm ON s.release_mbid = rm.release_mbid WHERE (rm.genre IS NULL OR rm.genre = '') AND (rm.genre_checked_at IS NULL OR rm.genre_checked_at < CAST(epoch(now()) AS INTEGER) - 604800) LIMIT ?"
+ [ unsafeCoerce limit ]
+ pure $ mapMaybe extractMbid rows
+ where
+ extractMbid json = do
+ obj <- toObject json
+ Object.lookup "release_mbid" obj >>= toString
+
upsertReleaseMetadata :: Connection -> String -> Maybe String -> Maybe String -> Maybe Int -> Aff Unit
upsertReleaseMetadata conn mbid genre label year = do
_ <- run conn
- "INSERT INTO release_metadata (release_mbid, genre, label, release_year) SELECT * FROM (SELECT ? as release_mbid, ? as genre, ? as label, ? as release_year) t WHERE NOT EXISTS (SELECT 1 FROM release_metadata WHERE release_mbid = t.release_mbid)"
+ "INSERT INTO release_metadata (release_mbid, genre, label, release_year) VALUES (?, ?, ?, ?) ON CONFLICT(release_mbid) DO UPDATE SET genre=excluded.genre, label=excluded.label, release_year=excluded.release_year"
[ unsafeCoerce mbid
, unsafeCoerce (toNullable genre)
, unsafeCoerce (toNullable label)
@@ -128,6 +142,12 @@ upsertReleaseMetadata conn mbid genre label year = do
]
pure unit
+touchGenreCheckedAt :: Connection -> String -> Aff Unit
+touchGenreCheckedAt conn mbid = do
+ run conn
+ "UPDATE release_metadata SET genre_checked_at = CAST(epoch(now()) AS INTEGER) WHERE release_mbid = ?"
+ [ unsafeCoerce mbid ]
+
getStats :: Connection -> Aff Stats
getStats conn = do
genreRows <- queryAll conn "SELECT rm.genre as name, COUNT(*) as count FROM scrobbles s JOIN release_metadata rm ON s.release_mbid = rm.release_mbid WHERE rm.genre IS NOT NULL AND rm.genre != '' GROUP BY rm.genre ORDER BY count DESC LIMIT 50" []
@@ -146,6 +166,19 @@ rowToEntry json = do
count <- Object.lookup "count" obj >>= (unsafeCoerce >>> Just)
pure $ StatsEntry { name, count }
+getArtistReleaseByMbid :: Connection -> String -> Aff (Maybe { artist :: String, release :: String })
+getArtistReleaseByMbid conn mbid = do
+ rows <- queryAll conn
+ "SELECT DISTINCT artist_name, release_name FROM scrobbles WHERE release_mbid = ? AND artist_name != '' AND release_name != '' LIMIT 1"
+ [ unsafeCoerce mbid ]
+ pure $ case uncons rows of
+ Just { head: row, tail: _ } -> do
+ obj <- toObject row
+ artist <- Object.lookup "artist_name" obj >>= toString
+ release <- Object.lookup "release_name" obj >>= toString
+ Just { artist, release }
+ Nothing -> Nothing
+
rowToListen :: Json -> Maybe Listen
rowToListen json = do
obj <- toObject json
diff --git a/src/Main.purs b/src/Main.purs
@@ -38,7 +38,7 @@ import Data.Array ((!!), length, uncons)
import Data.Nullable (Nullable, toMaybe)
import Data.Tuple (Tuple(..))
import Data.Foldable (for_)
-import Db (Connection, connect, initDb, upsertScrobble, getScrobbles, checkExists, run, initReleaseMetadata, getUnenrichedMbids, upsertReleaseMetadata, getStats)
+import Db (Connection, connect, initDb, upsertScrobble, getScrobbles, checkExists, run, initReleaseMetadata, getUnenrichedMbids, getEmptyGenreMbids, getArtistReleaseByMbid, upsertReleaseMetadata, touchGenreCheckedAt, getStats)
import Types (Listen(..), ListenBrainzResponse(..), Payload(..), TrackMetadata(..))
import Control.Monad.Rec.Class (forever)
import Data.Time.Duration (Milliseconds(..))
@@ -93,7 +93,7 @@ fetchListenBrainzDataBefore username maxTs = makeAff \callback -> do
pure nonCanceler
syncData :: Connection -> String -> Aff Unit
-syncData conn username | username == "" = pure unit
+syncData _ username | username == "" = pure unit
syncData conn username = do
forever do
void $ performFullSync
@@ -262,6 +262,15 @@ indexHtml =
border-radius: 4px;
object-fit: cover;
background: rgba(255, 255, 255, 0.05);
+ transition: transform 0.2s ease-in-out;
+ cursor: pointer;
+ }
+
+ .track-cover:hover {
+ transform: scale(5.0);
+ z-index: 10;
+ position: relative;
+ box-shadow: 0 8px 16px rgba(0, 0, 0, 0.5);
}
.loading {
@@ -804,7 +813,9 @@ fetchMusicBrainzRelease mbid = do
Right fr | fr.status == 200 -> do
jsonResult <- try $ fromJson fr.json
case jsonResult of
- Left _ -> pure $ Just { genre: Nothing, label: Nothing, year: Nothing }
+ Left err -> do
+ Log.error $ "MusicBrainz JSON parse error for " <> mbid <> ": " <> Exception.message err
+ pure $ Just { genre: Nothing, label: Nothing, year: Nothing }
Right json -> do
let
genre = do
@@ -826,6 +837,11 @@ fetchMusicBrainzRelease mbid = do
Just { head } -> fromString head
Nothing -> Nothing
Log.info $ "Enriched " <> mbid <> ": genre=" <> show genre <> " label=" <> show label <> " year=" <> show year
+
+ -- Warn if all fields are empty
+ when (genre == Nothing && label == Nothing && year == Nothing) $
+ Log.warn $ "All fields empty for " <> mbid <> " - possible parsing issue or missing data"
+
pure $ Just { genre, label, year }
Right fr | fr.status == 404 -> do
Log.info $ "MusicBrainz 404 for " <> mbid
@@ -834,19 +850,115 @@ fetchMusicBrainzRelease mbid = do
Log.warn $ "MusicBrainz " <> show fr.status <> " for " <> mbid <> ", will retry"
pure Nothing
+fetchLastfmGenre :: String -> String -> Aff (Maybe String)
+fetchLastfmGenre artist release = do
+ env <- liftEffect getEnv
+ case Object.lookup "LASTFM_API_KEY" env of
+ Nothing -> do
+ Log.warn "LASTFM_API_KEY missing for genre fallback"
+ pure Nothing
+ Just k -> do
+ let searchUrl = "https://ws.audioscrobbler.com/2.0/?method=album.getinfo&api_key=" <> k <> "&artist=" <> (fromMaybe "" $ encodeURIComponent artist) <> "&album=" <> (fromMaybe "" $ encodeURIComponent release) <> "&format=json"
+ Log.info $ "Fetching Last.fm genre for: " <> artist <> " - " <> release
+ result <- try $ fetch searchUrl { method: GET }
+ case result of
+ Right fetchRes | fetchRes.status == 200 -> do
+ jsonResult <- try $ fromJson fetchRes.json
+ case jsonResult of
+ Left err -> do
+ Log.error $ "Last.fm genre JSON error: " <> Exception.message err
+ pure Nothing
+ Right json -> do
+ let genre = do
+ obj <- toObject json
+ album <- Object.lookup "album" obj >>= toObject
+ tags <- Object.lookup "tags" album >>= toObject
+ tagArray <- Object.lookup "tag" tags >>= toArray
+ firstTag <- tagArray !! 0 >>= toObject
+ Object.lookup "name" firstTag >>= toString
+ pure genre
+ _ -> do
+ Log.warn "Last.fm genre API request failed"
+ pure Nothing
+
+fetchDiscogsGenre :: String -> String -> Aff (Maybe String)
+fetchDiscogsGenre artist release = do
+ env <- liftEffect getEnv
+ case Object.lookup "DISCOGS_TOKEN" env of
+ Nothing -> do
+ Log.warn "DISCOGS_TOKEN missing for genre fallback"
+ pure Nothing
+ Just t -> do
+ let queryStr = artist <> " " <> release
+ let searchUrl = "https://api.discogs.com/database/search?q=" <> (fromMaybe "" $ encodeURIComponent queryStr) <> "&type=release&per_page=1&token=" <> t
+ Log.info $ "Fetching Discogs genre for: " <> queryStr
+ result <- try $ fetch searchUrl { method: GET, headers: { "User-Agent": "ScrobblerPureScript/1.0" } }
+ case result of
+ Right fetchRes | fetchRes.status == 200 -> do
+ jsonResult <- try $ fromJson fetchRes.json
+ case jsonResult of
+ Left err -> do
+ Log.error $ "Discogs genre JSON error: " <> Exception.message err
+ pure Nothing
+ Right json -> do
+ let genre = do
+ obj <- toObject json
+ results <- Object.lookup "results" obj >>= toArray
+ firstResult <- results !! 0 >>= toObject
+ genres <- Object.lookup "genres" firstResult >>= toArray
+ genres !! 0 >>= toString
+ pure genre
+ _ -> do
+ Log.warn "Discogs genre API request failed"
+ pure Nothing
+
enrichMetadata :: Connection -> Aff Unit
enrichMetadata conn = forever do
- mbids <- getUnenrichedMbids conn 10
- if length mbids == 0 then
+ -- Get both unenriched and empty genre MBIDs
+ unenrichedMbids <- getUnenrichedMbids conn 10
+ emptyGenreMbids <- getEmptyGenreMbids conn 10
+ let allMbids = unenrichedMbids <> emptyGenreMbids
+
+ if length allMbids == 0 then
delay (Milliseconds 60000.0)
else do
- for_ mbids \mbid -> do
+ Log.info $ "Processing " <> show (length unenrichedMbids) <> " unenriched + " <> show (length emptyGenreMbids) <> " empty genre releases"
+ for_ allMbids \mbid -> do
delay (Milliseconds 1100.0)
result <- try $ fetchMusicBrainzRelease mbid
case result of
Left err -> Log.error $ "Enrichment error: " <> Exception.message err
Right Nothing -> pure unit
- Right (Just mbdata) -> upsertReleaseMetadata conn mbid mbdata.genre mbdata.label mbdata.year
+ Right (Just mbdata) -> do
+ -- If genre is empty, try fallback sources
+ if mbdata.genre == Nothing then do
+ artistRelease <- getArtistReleaseByMbid conn mbid
+ case artistRelease of
+ Just { artist, release } -> do
+ -- Try Last.fm first
+ lastfmGenre <- fetchLastfmGenre artist release
+ finalGenre <- case lastfmGenre of
+ Just _ -> pure lastfmGenre
+ Nothing -> do
+ -- Try Discogs as final fallback
+ fetchDiscogsGenre artist release
+
+ -- Update with the best genre we found
+ let finalMbdata = mbdata { genre = finalGenre }
+ upsertReleaseMetadata conn mbid finalMbdata.genre finalMbdata.label finalMbdata.year
+
+ case finalGenre of
+ Just genre -> Log.info $ "Added fallback genre from " <> (if lastfmGenre /= Nothing then "Last.fm" else "Discogs") <> " for " <> mbid <> ": " <> genre
+ Nothing -> do
+ Log.info $ "No genre found in any source for " <> mbid
+ touchGenreCheckedAt conn mbid
+ Nothing -> do
+ Log.warn $ "No artist/release info found for MBID " <> mbid <> ", cannot use fallback sources"
+ upsertReleaseMetadata conn mbid mbdata.genre mbdata.label mbdata.year
+ touchGenreCheckedAt conn mbid
+ else do
+ -- Genre found in MusicBrainz, just save as usual
+ upsertReleaseMetadata conn mbid mbdata.genre mbdata.label mbdata.year
startServer :: Int -> String -> String -> Effect Unit
startServer port dbFile username = launchAff_ do
