commit 97eeb6e2e3f7a42c8618c8f53d579d4b5e15e37a
parent cdfe2766168c3942aa8abbf906dbdf4f989badb7
Author: mtmn <miro@haravara.org>
Date: Sat, 11 Apr 2026 16:41:58 +0200
feat: add stats
Diffstat:
| M | src/Client.purs | | | 170 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++----------- |
| M | src/Db.purs | | | 68 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++---- |
| M | src/Main.purs | | | 220 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-- |
| M | src/Types.purs | | | 45 | +++++++++++++++++++++++++++++++++++++++++++++ |
4 files changed, 473 insertions(+), 30 deletions(-)
diff --git a/src/Client.purs b/src/Client.purs
@@ -7,7 +7,8 @@ import Affjax.ResponseFormat as ResponseFormat
import Data.Argonaut (decodeJson)
import Data.Array (mapWithIndex, length)
import Data.Either (Either(..))
-import Data.Int (floor, fromString)
+import Data.Int (floor, fromString, toNumber)
+import Data.Foldable (maximum)
import Data.Maybe (Maybe(..), fromMaybe)
import Effect (Effect)
import Effect.Aff (Aff, delay)
@@ -23,7 +24,7 @@ import Halogen.HTML.Properties as HP
import Halogen.VDom.Driver (runUI)
import JSURI (encodeURIComponent)
import Web.DOM.ParentNode (QuerySelector(..))
-import Types (Listen(..), ListenBrainzResponse(..), TrackMetadata(..), Payload(..), MbidMapping(..))
+import Types (Listen(..), ListenBrainzResponse(..), TrackMetadata(..), Payload(..), MbidMapping(..), Stats(..), StatsEntry(..))
import Data.Time.Duration (Milliseconds(..))
import Data.DateTime.Instant (Instant, unInstant)
import Data.Set (Set)
@@ -35,8 +36,15 @@ import Web.HTML.History (pushState, DocumentTitle(..), URL(..))
import Foreign (unsafeToForeign)
import Data.Nullable (Nullable, toMaybe)
+data Tab = ListensTab | StatsTab
+
+derive instance eqTab :: Eq Tab
+
+type ActiveFilter = { field :: String, value :: String }
+
type State =
{ listens :: Array Listen
+ , stats :: Maybe Stats
, lastCheck :: Maybe String
, error :: Maybe String
, loading :: Boolean
@@ -44,15 +52,21 @@ type State =
, failedCovers :: Set String
, offset :: Int
, limit :: Int
+ , activeTab :: Tab
+ , activeFilter :: Maybe ActiveFilter
}
data Action
= Initialize
| Refresh
| ReceiveResponse (Either String (Array Listen))
+ | ReceiveStats (Either String Stats)
| ImageError String
| NextPage
| PrevPage
+ | SwitchTab Tab
+ | FilterBy String String
+ | ClearFilter
component :: forall query input output m. MonadAff m => H.Component query input output m
component =
@@ -67,6 +81,7 @@ component =
where
initialState _ =
{ listens: []
+ , stats: Nothing
, lastCheck: Nothing
, error: Nothing
, loading: true
@@ -74,29 +89,64 @@ component =
, failedCovers: Set.empty
, offset: 0
, limit: 25
+ , activeTab: ListensTab
+ , activeFilter: Nothing
}
render state =
HH.div
[ HP.class_ (H.ClassName "container") ]
[ HH.h1_ [ HH.text "scorpus" ]
- , renderContent state
, HH.div
- [ HP.class_ (H.ClassName "pagination") ]
+ [ HP.class_ (H.ClassName "tabs") ]
[ HH.button
- [ HP.class_ (H.ClassName "page-btn")
- , HP.disabled (state.offset == 0 || state.loading)
- , HE.onClick \_ -> PrevPage
+ [ HP.class_ (H.ClassName $ "tab-btn" <> if state.activeTab == ListensTab then " active" else "")
+ , HE.onClick \_ -> SwitchTab ListensTab
]
- [ HH.text "Previous" ]
- , HH.div [ HP.class_ (H.ClassName "page-indicator") ] [ HH.text $ "Page " <> show (state.offset / state.limit + 1) ]
+ [ HH.text "listens" ]
, HH.button
- [ HP.class_ (H.ClassName "page-btn")
- , HP.disabled (length state.listens < state.limit || state.loading)
- , HE.onClick \_ -> NextPage
+ [ HP.class_ (H.ClassName $ "tab-btn" <> if state.activeTab == StatsTab then " active" else "")
+ , HE.onClick \_ -> SwitchTab StatsTab
]
- [ HH.text "Next" ]
+ [ HH.text "stats" ]
]
+ , case state.activeTab of
+ ListensTab ->
+ HH.div_
+ [ case state.activeFilter of
+ Nothing -> HH.text ""
+ Just { field, value } ->
+ HH.div [ HP.class_ (H.ClassName "filter-banner") ]
+ [ HH.span [ HP.class_ (H.ClassName "filter-label") ]
+ [ HH.text $ field <> ": "
+ , HH.strong_ [ HH.text value ]
+ ]
+ , HH.button
+ [ HP.class_ (H.ClassName "filter-clear")
+ , HE.onClick \_ -> ClearFilter
+ ]
+ [ HH.text "✕ clear" ]
+ ]
+ , renderContent state
+ , HH.div
+ [ HP.class_ (H.ClassName "pagination") ]
+ [ HH.button
+ [ HP.class_ (H.ClassName "page-btn")
+ , HP.disabled (state.offset == 0 || state.loading)
+ , HE.onClick \_ -> PrevPage
+ ]
+ [ HH.text "Previous" ]
+ , HH.div [ HP.class_ (H.ClassName "page-indicator") ] [ HH.text $ "Page " <> show (state.offset / state.limit + 1) ]
+ , HH.button
+ [ HP.class_ (H.ClassName "page-btn")
+ , HP.disabled (length state.listens < state.limit || state.loading)
+ , HE.onClick \_ -> NextPage
+ ]
+ [ HH.text "Next" ]
+ ]
+ ]
+ StatsTab ->
+ renderStatsView state.stats
, HH.p
[ HP.id "last-updated"
, HP.class_ (H.ClassName "small")
@@ -104,6 +154,44 @@ component =
[ HH.text $ fromMaybe "" state.lastCheck ]
]
+ renderStatsView Nothing =
+ HH.div [ HP.class_ (H.ClassName "loading") ] [ HH.text "Loading stats..." ]
+ renderStatsView (Just (Stats { genres, labels, years })) =
+ HH.div_
+ [ renderStatSection "genre" "genres" genres
+ , renderStatSection "label" "labels" labels
+ , renderStatSection "year" "years" years
+ ]
+
+ renderStatSection field title entries =
+ let
+ maxCount = fromMaybe 1 (maximum (map (\(StatsEntry e) -> e.count) entries))
+ in
+ HH.div [ HP.class_ (H.ClassName "stats-section") ]
+ [ HH.h2_ [ HH.text title ]
+ , if entries == [] then
+ HH.div [ HP.class_ (H.ClassName "stats-empty") ] [ HH.text "no data yet — enrichment in progress" ]
+ else
+ HH.ul_ (map (renderStatEntry maxCount field) entries)
+ ]
+
+ renderStatEntry maxCount field (StatsEntry { name, count }) =
+ let
+ barPct = floor (toNumber count * 100.0 / toNumber maxCount)
+ in
+ HH.li
+ [ HP.class_ (H.ClassName "stat-row")
+ , HE.onClick \_ -> FilterBy field name
+ ]
+ [ HH.div
+ [ HP.class_ (H.ClassName "stat-bar")
+ , HP.style $ "width: " <> show barPct <> "%"
+ ]
+ []
+ , HH.span [ HP.class_ (H.ClassName "stat-name") ] [ HH.text name ]
+ , HH.span [ HP.class_ (H.ClassName "stat-count") ] [ HH.text $ show count ]
+ ]
+
renderContent state
| state.loading && state.listens == [] =
HH.ul_ [ HH.li [ HP.class_ (H.ClassName "loading") ] [ HH.text "Loading recent tracks..." ] ]
@@ -123,11 +211,14 @@ component =
Just (MbidMapping { releaseMbid: Just m }) -> Just m
_ -> Nothing
- coverUrl = "/cover?artist=" <> (fromMaybe "" $ encodeURIComponent artist)
- <> "&release=" <> (fromMaybe "" $ encodeURIComponent release)
- <> (case mbid of
- Just m -> "&mbid=" <> m
- Nothing -> "")
+ coverUrl = "/cover?artist=" <> (fromMaybe "" $ encodeURIComponent artist)
+ <> "&release="
+ <> (fromMaybe "" $ encodeURIComponent release)
+ <>
+ ( case mbid of
+ Just m -> "&mbid=" <> m
+ Nothing -> ""
+ )
in
HH.li
[ HP.class_ (H.ClassName "success") ]
@@ -164,7 +255,6 @@ component =
]
]
-
handleAction = case _ of
Initialize -> do
w <- liftEffect window
@@ -181,7 +271,7 @@ component =
Refresh -> do
state <- H.get
H.modify_ _ { loading = true, error = Nothing }
- response <- H.liftAff $ fetchListens state.limit state.offset
+ response <- H.liftAff $ fetchListens state.limit state.offset state.activeFilter
handleAction (ReceiveResponse response)
ReceiveResponse result -> do
nowInstant <- liftEffect now
@@ -190,6 +280,26 @@ component =
case result of
Left err -> H.modify_ _ { loading = false, error = Just err, lastCheck = Just nowStr, currentTime = Just nowMs }
Right listens -> H.modify_ _ { loading = false, listens = listens, lastCheck = Just nowStr, currentTime = Just nowMs }
+ ReceiveStats result -> case result of
+ Left err -> H.modify_ _ { error = Just err }
+ Right stats -> H.modify_ _ { stats = Just stats }
+ FilterBy field value -> do
+ H.modify_ _ { activeFilter = Just { field, value }, offset = 0, activeTab = ListensTab }
+ updateUrl
+ handleAction Refresh
+ ClearFilter -> do
+ H.modify_ _ { activeFilter = Nothing, offset = 0 }
+ updateUrl
+ handleAction Refresh
+ SwitchTab tab -> do
+ H.modify_ _ { activeTab = tab }
+ case tab of
+ StatsTab -> do
+ state <- H.get
+ when (state.stats == Nothing) do
+ response <- H.liftAff fetchStats
+ handleAction (ReceiveStats response)
+ ListensTab -> pure unit
ImageError url -> do
H.modify_ \state -> state { failedCovers = Set.insert url state.failedCovers }
NextPage -> do
@@ -209,9 +319,13 @@ component =
h <- history w
pushState (unsafeToForeign {}) (DocumentTitle "") (URL $ "?page=" <> show page) h
- fetchListens :: Int -> Int -> Aff (Either String (Array Listen))
- fetchListens limit offset = do
- let url = "/proxy?limit=" <> show limit <> "&offset=" <> show offset
+ fetchListens :: Int -> Int -> Maybe ActiveFilter -> Aff (Either String (Array Listen))
+ fetchListens limit offset mFilter = do
+ let
+ filterParams = case mFilter of
+ Nothing -> ""
+ Just { field, value } -> "&filterField=" <> field <> "&filterValue=" <> (fromMaybe value (encodeURIComponent value))
+ let url = "/proxy?limit=" <> show limit <> "&offset=" <> show offset <> filterParams
res <- AX.get ResponseFormat.json url
case res of
Left err -> pure $ Left $ "Network error: " <> AX.printError err
@@ -220,6 +334,16 @@ component =
Left err -> pure $ Left $ "JSON decode error: " <> show err
Right (ListenBrainzResponse { payload: Payload { listens } }) -> pure $ Right listens
+ fetchStats :: Aff (Either String Stats)
+ fetchStats = do
+ res <- AX.get ResponseFormat.json "/stats"
+ case res of
+ Left err -> pure $ Left $ "Network error: " <> AX.printError err
+ Right response ->
+ case decodeJson response.body of
+ Left err -> pure $ Left $ "JSON decode error: " <> show err
+ Right stats -> pure $ Right stats
+
formatTimeAgo :: Maybe Milliseconds -> Maybe Int -> Maybe String
formatTimeAgo Nothing _ = Nothing
formatTimeAgo _ Nothing = Nothing
diff --git a/src/Db.purs b/src/Db.purs
@@ -10,10 +10,11 @@ import Effect.Aff (Aff, makeAff, nonCanceler)
import Effect.Exception (Error, error)
import Foreign (Foreign)
import Unsafe.Coerce (unsafeCoerce)
-import Types (Listen(..), TrackMetadata(..), MbidMapping(..))
+import Types (Listen(..), TrackMetadata(..), MbidMapping(..), Stats(..), StatsEntry(..))
import Data.Traversable (traverse)
import Foreign.Object as Object
-import Data.Nullable (Nullable, toMaybe)
+import Data.Nullable (Nullable, toMaybe, toNullable)
+import Data.Array (mapMaybe)
foreign import data Connection :: Type
@@ -79,11 +80,70 @@ upsertScrobble conn (Listen { listenedAt, trackMetadata: TrackMetadata track })
_ <- run conn "INSERT INTO scrobbles SELECT * FROM (SELECT ? as listened_at, ? as track_name, ? as artist_name, ? as release_name, ? as release_mbid, ? as caa_release_mbid) t WHERE NOT EXISTS (SELECT 1 FROM scrobbles WHERE listened_at = t.listened_at)" params
pure unit
-getScrobbles :: Connection -> Int -> Int -> Aff (Array Listen)
-getScrobbles conn limit offset = do
+getScrobbles :: Connection -> Int -> Int -> Maybe { field :: String, value :: String } -> Aff (Array Listen)
+getScrobbles conn limit offset Nothing = do
rows <- queryAll conn "SELECT listened_at, track_name, artist_name, release_name, release_mbid, caa_release_mbid FROM scrobbles ORDER BY listened_at DESC LIMIT ? OFFSET ?"
[ unsafeCoerce limit, unsafeCoerce offset ]
pure $ fromMaybe [] $ traverse rowToListen rows
+getScrobbles conn limit offset (Just { field, value }) = do
+ let
+ col = case field of
+ "label" -> "rm.label"
+ "year" -> "rm.release_year::VARCHAR"
+ _ -> "rm.genre"
+ rows <- queryAll conn
+ ( "SELECT s.listened_at, s.track_name, s.artist_name, s.release_name, s.release_mbid, s.caa_release_mbid"
+ <> " FROM scrobbles s JOIN release_metadata rm ON s.release_mbid = rm.release_mbid"
+ <> " WHERE "
+ <> col
+ <> " = ? ORDER BY s.listened_at DESC LIMIT ? OFFSET ?"
+ )
+ [ unsafeCoerce value, unsafeCoerce limit, unsafeCoerce offset ]
+ pure $ fromMaybe [] $ traverse rowToListen rows
+
+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)" []
+
+getUnenrichedMbids :: Connection -> Int -> Aff (Array String)
+getUnenrichedMbids conn limit = do
+ rows <- queryAll conn
+ "SELECT DISTINCT release_mbid FROM scrobbles WHERE release_mbid != '' AND release_mbid NOT IN (SELECT release_mbid FROM release_metadata) 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)"
+ [ unsafeCoerce mbid
+ , unsafeCoerce (toNullable genre)
+ , unsafeCoerce (toNullable label)
+ , unsafeCoerce (toNullable year)
+ ]
+ pure unit
+
+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" []
+ labelRows <- queryAll conn "SELECT rm.label as name, COUNT(*) as count FROM scrobbles s JOIN release_metadata rm ON s.release_mbid = rm.release_mbid WHERE rm.label IS NOT NULL AND rm.label != '' GROUP BY rm.label ORDER BY count DESC LIMIT 50" []
+ yearRows <- queryAll conn "SELECT CAST(rm.release_year AS VARCHAR) as name, COUNT(*) as count FROM scrobbles s JOIN release_metadata rm ON s.release_mbid = rm.release_mbid WHERE rm.release_year IS NOT NULL GROUP BY rm.release_year ORDER BY rm.release_year DESC" []
+ pure $ Stats
+ { genres: mapMaybe rowToEntry genreRows
+ , labels: mapMaybe rowToEntry labelRows
+ , years: mapMaybe rowToEntry yearRows
+ }
+
+rowToEntry :: Json -> Maybe StatsEntry
+rowToEntry json = do
+ obj <- toObject json
+ name <- Object.lookup "name" obj >>= toString
+ count <- Object.lookup "count" obj >>= (unsafeCoerce >>> Just)
+ pure $ StatsEntry { name, count }
rowToListen :: Json -> Maybe Listen
rowToListen json = do
diff --git a/src/Main.purs b/src/Main.purs
@@ -37,7 +37,8 @@ import Data.Argonaut.Core (toObject, toArray, toString, stringify)
import Data.Array ((!!), length, uncons)
import Data.Nullable (Nullable, toMaybe)
import Data.Tuple (Tuple(..))
-import Db (Connection, connect, initDb, upsertScrobble, getScrobbles, checkExists, run)
+import Data.Foldable (for_)
+import Db (Connection, connect, initDb, upsertScrobble, getScrobbles, checkExists, run, initReleaseMetadata, getUnenrichedMbids, upsertReleaseMetadata, getStats)
import Types (Listen(..), ListenBrainzResponse(..), Payload(..), TrackMetadata(..))
import Control.Monad.Rec.Class (forever)
import Data.Time.Duration (Milliseconds(..))
@@ -160,7 +161,7 @@ indexHtml =
<head>
<meta charset="UTF-8">
<meta name="viewport" content="width=device-width, initial-scale=1.0">
- <title>scorpus</title>
+ <title>scrobbler</title>
<link rel="icon" type="image/x-icon" href="/favicon.ico">
<link rel="icon" type="image/png" href="/favicon.png">
<link rel="preconnect" href="https://fonts.googleapis.com">
@@ -353,6 +354,139 @@ indexHtml =
font-size: 14px;
color: #9fbfe7;
}
+
+ .tabs {
+ display: flex;
+ gap: 10px;
+ margin-bottom: 20px;
+ }
+
+ .tab-btn {
+ background: none;
+ border: 1px solid #50447f;
+ color: #9fbfe7;
+ padding: 6px 14px;
+ border-radius: 4px;
+ cursor: pointer;
+ font-family: inherit;
+ font-size: 12px;
+ }
+
+ .tab-btn.active {
+ background: #521e40;
+ color: #ffffff;
+ box-shadow: 2px 2px 0px #50447f;
+ }
+
+ .tab-btn:hover {
+ color: #ffffff;
+ }
+
+ .stats-section {
+ margin-bottom: 30px;
+ }
+
+ .stats-section h2 {
+ font-size: 11px;
+ color: #9fbfe7;
+ text-transform: uppercase;
+ letter-spacing: 3px;
+ margin: 0 0 10px 0;
+ border-bottom: 1px solid #50447f;
+ padding-bottom: 5px;
+ }
+
+ .stat-row {
+ display: flex;
+ justify-content: space-between;
+ align-items: center;
+ padding: 5px 8px;
+ margin-bottom: 3px;
+ position: relative;
+ border-radius: 2px;
+ overflow: hidden;
+ font-size: 13px;
+ }
+
+ .stat-bar {
+ position: absolute;
+ left: 0;
+ top: 0;
+ height: 100%;
+ background: #521e40;
+ border-right: 1px solid #50447f;
+ z-index: 0;
+ }
+
+ .stat-name {
+ position: relative;
+ z-index: 1;
+ color: #ffffff;
+ flex: 1;
+ padding-right: 10px;
+ white-space: nowrap;
+ overflow: hidden;
+ text-overflow: ellipsis;
+ }
+
+ .stat-count {
+ position: relative;
+ z-index: 1;
+ color: #9fbfe7;
+ font-size: 12px;
+ flex-shrink: 0;
+ }
+
+ .stats-empty {
+ color: #9fbfe7;
+ font-size: 13px;
+ padding: 10px 0;
+ }
+
+ .stat-row {
+ cursor: pointer;
+ }
+
+ .stat-row:hover .stat-name {
+ color: #a0c0d0;
+ }
+
+ .filter-banner {
+ display: flex;
+ align-items: center;
+ gap: 10px;
+ background: #521e40;
+ border: 1px solid #50447f;
+ border-radius: 4px;
+ padding: 8px 12px;
+ margin-bottom: 12px;
+ font-size: 13px;
+ color: #9fbfe7;
+ }
+
+ .filter-label {
+ flex: 1;
+ }
+
+ .filter-label strong {
+ color: #ffffff;
+ }
+
+ .filter-clear {
+ background: none;
+ border: 1px solid #50447f;
+ color: #9fbfe7;
+ padding: 2px 8px;
+ border-radius: 3px;
+ cursor: pointer;
+ font-family: inherit;
+ font-size: 12px;
+ }
+
+ .filter-clear:hover {
+ color: #ffffff;
+ border-color: #ffffff;
+ }
</style>
</head>
<body>
@@ -374,6 +508,7 @@ handleRequest db req res = do
"/" -> serveIndex res
"/proxy" -> serveProxy db url res
"/cover" -> serveCover url res
+ "/stats" -> serveStats db res
"/client.js" -> serveClientJs res
"/favicon.ico" -> serveAsset "image/x-icon" "assets/favicon.ico" res
"/favicon.png" -> serveAsset "image/png" "assets/favicon.png" res
@@ -578,11 +713,18 @@ serveProxy db url res = do
launchAff_ do
limitStr <- liftEffect $ getQueryParam "limit" url
offsetStr <- liftEffect $ getQueryParam "offset" url
+ filterFieldStr <- liftEffect $ getQueryParam "filterField" url
+ filterValueStr <- liftEffect $ getQueryParam "filterValue" url
let limit = fromMaybe 25 (toMaybe limitStr >>= fromString)
let offset = fromMaybe 0 (toMaybe offsetStr >>= fromString)
+ let
+ mFilter = do
+ field <- toMaybe filterFieldStr
+ value <- toMaybe filterValueStr
+ pure { field, value }
- listens <- getScrobbles db limit offset
+ listens <- getScrobbles db limit offset mFilter
let responseBody = stringify $ encodeJson { payload: { listens: listens } }
liftEffect $ do
@@ -614,11 +756,83 @@ serveNotFound res = do
void $ writeString w UTF8 "Not Found"
end w
+serveStats :: Connection -> Response -> Effect Unit
+serveStats db res = do
+ setHeader "Content-Type" "application/json" (toOutgoingMessage res)
+ setHeader "Access-Control-Allow-Origin" "*" (toOutgoingMessage res)
+ launchAff_ do
+ stats <- getStats db
+ let responseBody = stringify $ encodeJson stats
+ liftEffect $ do
+ setStatusCode 200 res
+ let w = toWriteable (toOutgoingMessage res)
+ void $ writeString w UTF8 responseBody
+ end w
+
+type MbData = { genre :: Maybe String, label :: Maybe String, year :: Maybe Int }
+
+fetchMusicBrainzRelease :: String -> Aff (Maybe MbData)
+fetchMusicBrainzRelease mbid = do
+ let url = "https://musicbrainz.org/ws/2/release/" <> mbid <> "?inc=genres+labels+release-groups&fmt=json"
+ result <- try $ fetch url { method: GET, headers: { "User-Agent": "Scorpus/1.0 +https://codeberg.org/mtmn/scorpus" } }
+ case result of
+ Left err -> do
+ Log.error $ "MusicBrainz fetch error for " <> mbid <> ": " <> Exception.message err
+ pure Nothing
+ Right fr | fr.status == 200 -> do
+ jsonResult <- try $ fromJson fr.json
+ case jsonResult of
+ Left _ -> pure $ Just { genre: Nothing, label: Nothing, year: Nothing }
+ Right json -> do
+ let
+ genre = do
+ obj <- toObject json
+ genres <- Object.lookup "genres" obj >>= toArray
+ firstGenre <- genres !! 0 >>= toObject
+ Object.lookup "name" firstGenre >>= toString
+ label = do
+ obj <- toObject json
+ labelInfo <- Object.lookup "label-info" obj >>= toArray
+ firstLabel <- labelInfo !! 0 >>= toObject
+ labelObj <- Object.lookup "label" firstLabel >>= toObject
+ Object.lookup "name" labelObj >>= toString
+ year = do
+ obj <- toObject json
+ rg <- Object.lookup "release-group" obj >>= toObject
+ dateStr <- Object.lookup "first-release-date" rg >>= toString
+ case uncons (split "-" dateStr) of
+ Just { head } -> fromString head
+ Nothing -> Nothing
+ Log.info $ "Enriched " <> mbid <> ": genre=" <> show genre <> " label=" <> show label <> " year=" <> show year
+ pure $ Just { genre, label, year }
+ Right fr | fr.status == 404 -> do
+ Log.info $ "MusicBrainz 404 for " <> mbid
+ pure $ Just { genre: Nothing, label: Nothing, year: Nothing }
+ Right fr -> do
+ Log.warn $ "MusicBrainz " <> show fr.status <> " for " <> mbid <> ", will retry"
+ pure Nothing
+
+enrichMetadata :: Connection -> Aff Unit
+enrichMetadata conn = forever do
+ mbids <- getUnenrichedMbids conn 10
+ if length mbids == 0 then
+ delay (Milliseconds 60000.0)
+ else do
+ for_ mbids \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
+
startServer :: Int -> String -> Effect Unit
startServer port dbFile = launchAff_ do
conn <- connect dbFile
initDb conn
+ initReleaseMetadata conn
void $ forkAff $ syncData conn
+ void $ forkAff $ enrichMetadata conn
liftEffect $ do
server <- createServer
diff --git a/src/Types.purs b/src/Types.purs
@@ -111,3 +111,48 @@ instance EncodeJson MbidMapping where
"release_mbid" := encodeJson releaseMbid
~> "caa_release_mbid" := encodeJson caaReleaseMbid
~> jsonEmptyObject
+
+newtype StatsEntry = StatsEntry
+ { name :: String
+ , count :: Int
+ }
+
+derive instance eqStatsEntry :: Eq StatsEntry
+derive instance genericStatsEntry :: Generic StatsEntry _
+
+instance DecodeJson StatsEntry where
+ decodeJson json = do
+ obj <- decodeJson json
+ name <- obj .: "name"
+ count <- obj .: "count"
+ pure $ StatsEntry { name, count }
+
+instance EncodeJson StatsEntry where
+ encodeJson (StatsEntry { name, count }) =
+ "name" := encodeJson name
+ ~> "count" := encodeJson count
+ ~> jsonEmptyObject
+
+newtype Stats = Stats
+ { genres :: Array StatsEntry
+ , labels :: Array StatsEntry
+ , years :: Array StatsEntry
+ }
+
+derive instance eqStats :: Eq Stats
+derive instance genericStats :: Generic Stats _
+
+instance DecodeJson Stats where
+ decodeJson json = do
+ obj <- decodeJson json
+ genres <- obj .: "genres"
+ labels <- obj .: "labels"
+ years <- obj .: "years"
+ pure $ Stats { genres, labels, years }
+
+instance EncodeJson Stats where
+ encodeJson (Stats { genres, labels, years }) =
+ "genres" := encodeJson genres
+ ~> "labels" := encodeJson labels
+ ~> "years" := encodeJson years
+ ~> jsonEmptyObject
