corpus

self-hosted listenbrainz and last.fm proxy
Log | Files | Refs | README | LICENSE

Metadata.purs (9397B)

      1 module Metadata
      2   ( MbData
      3   , GenreSource
      4   , fetchMusicBrainzRelease
      5   , fetchLastfmGenre
      6   , fetchDiscogsGenre
      7   , fetchFallbackGenre
      8   , enrichMetadata
      9   ) where
     10 
     11 import Prelude
     12 
     13 import Config (UserConfig)
     14 import Control.Monad.Rec.Class (forever)
     15 import Data.Array ((!!), length, null)
     16 import Data.Either (Either(..))
     17 import Data.Foldable (foldM, for_)
     18 import Data.Int (fromString)
     19 import Data.Maybe (Maybe(..), fromMaybe, isJust)
     20 import Data.String (Pattern(..))
     21 import Data.String.Common as String
     22 import Data.Time.Duration (Milliseconds(..))
     23 import Data.Argonaut.Core (toArray, toObject, toString)
     24 import Db (Connection, getArtistReleasesByMbids, getEmptyGenreMbids, getUnenrichedMbids, touchGenreCheckedAt, upsertReleaseMetadata)
     25 import Effect.Aff (Aff, delay, try)
     26 import Effect.Class (liftEffect)
     27 import Effect.Exception as Exception
     28 import Fetch (fetch, Method(GET))
     29 import Fetch.Argonaut.Json (fromJson)
     30 import Foreign.Object as Object
     31 import JSURI (encodeURIComponent)
     32 import Log as Log
     33 import Metrics as Metrics
     34 
     35 type MbData = { genre :: Maybe String, label :: Maybe String, year :: Maybe Int }
     36 
     37 type GenreSource =
     38   { name :: String
     39   , enabled :: Boolean
     40   , fetch :: Aff (Maybe String)
     41   }
     42 
     43 fetchMusicBrainzRelease :: String -> Aff (Maybe MbData)
     44 fetchMusicBrainzRelease mbid = do
     45   let url = "https://musicbrainz.org/ws/2/release/" <> mbid <> "?inc=genres+labels+release-groups&fmt=json"
     46   result <- try $ fetch url { method: GET, headers: { "User-Agent": "corpus/1.0 +https://sr.ht/~mtmn/corpus" } }
     47   case result of
     48     Left err -> do
     49       Log.error $ "MusicBrainz fetch error for " <> mbid <> ": " <> Exception.message err
     50       pure Nothing
     51     Right fr | fr.status == 200 -> do
     52       jsonResult <- try $ fromJson fr.json
     53       case jsonResult of
     54         Left err -> do
     55           Log.error $ "MusicBrainz JSON parse error for " <> mbid <> ": " <> Exception.message err
     56           pure $ Just { genre: Nothing, label: Nothing, year: Nothing }
     57         Right json -> do
     58           let
     59             genre = do
     60               obj <- toObject json
     61               genres <- Object.lookup "genres" obj >>= toArray
     62               firstGenre <- genres !! 0 >>= toObject
     63               Object.lookup "name" firstGenre >>= toString
     64             label = do
     65               obj <- toObject json
     66               labelInfo <- Object.lookup "label-info" obj >>= toArray
     67               firstLabel <- labelInfo !! 0 >>= toObject
     68               labelObj <- Object.lookup "label" firstLabel >>= toObject
     69               Object.lookup "name" labelObj >>= toString
     70             year = do
     71               obj <- toObject json
     72               rg <- Object.lookup "release-group" obj >>= toObject
     73               dateStr <- Object.lookup "first-release-date" rg >>= toString
     74               String.split (Pattern "-") dateStr !! 0 >>= fromString
     75           Log.info $ "Enriched " <> mbid <> ": genre=" <> show genre <> " label=" <> show label <> " year=" <> show year
     76           when (genre == Nothing && label == Nothing && year == Nothing)
     77             $ Log.warn
     78             $ "All fields empty for " <> mbid <> " - possible parsing issue or missing data"
     79           pure $ Just { genre, label, year }
     80     Right fr | fr.status == 404 -> do
     81       Log.info $ "MusicBrainz 404 for " <> mbid
     82       pure $ Just { genre: Nothing, label: Nothing, year: Nothing }
     83     Right fr -> do
     84       Log.warn $ "MusicBrainz " <> show fr.status <> " for " <> mbid <> ", will retry"
     85       pure Nothing
     86 
     87 fetchLastfmGenre :: Maybe String -> String -> String -> Aff (Maybe String)
     88 fetchLastfmGenre Nothing _ _ = do
     89   Log.warn "lastfmApiKey not configured for genre fallback"
     90   pure Nothing
     91 fetchLastfmGenre (Just k) artist release = do
     92   let searchUrl = "https://ws.audioscrobbler.com/2.0/?method=album.getinfo&artist=" <> (fromMaybe "" $ encodeURIComponent artist) <> "&album=" <> (fromMaybe "" $ encodeURIComponent release) <> "&format=json" <> "&api_key=" <> k
     93   Log.info $ "Fetching Last.fm genre for: " <> artist <> " - " <> release
     94   result <- try $ fetch searchUrl { method: GET }
     95   case result of
     96     Right fetchRes | fetchRes.status == 200 -> do
     97       jsonResult <- try $ fromJson fetchRes.json
     98       case jsonResult of
     99         Left err -> do
    100           Log.error $ "Last.fm genre JSON error: " <> Exception.message err
    101           pure Nothing
    102         Right json -> do
    103           let
    104             genre = do
    105               obj <- toObject json
    106               album <- Object.lookup "album" obj >>= toObject
    107               tags <- Object.lookup "tags" album >>= toObject
    108               mTag <- Object.lookup "tag" tags
    109               let tagArray = fromMaybe [ mTag ] (toArray mTag)
    110               firstTag <- tagArray !! 0 >>= toObject
    111               Object.lookup "name" firstTag >>= toString
    112           pure genre
    113     _ -> do
    114       Log.warn "Last.fm genre API request failed"
    115       pure Nothing
    116 
    117 fetchDiscogsGenre :: Maybe String -> String -> String -> Aff (Maybe String)
    118 fetchDiscogsGenre Nothing _ _ = do
    119   Log.warn "discogsToken not configured for genre fallback"
    120   pure Nothing
    121 fetchDiscogsGenre (Just t) artist release = do
    122   let queryStr = artist <> " " <> release
    123   let searchUrl = "https://api.discogs.com/database/search?q=" <> (fromMaybe "" $ encodeURIComponent queryStr) <> "&type=release&per_page=1"
    124   Log.info $ "Fetching Discogs genre for: " <> queryStr
    125   result <- try $ fetch searchUrl { method: GET, headers: { "User-Agent": "corpus/1.0 +https://sr.ht/~mtmn/corpus", "Authorization": "Discogs token=" <> t } }
    126   case result of
    127     Right fetchRes | fetchRes.status == 200 -> do
    128       jsonResult <- try $ fromJson fetchRes.json
    129       case jsonResult of
    130         Left err -> do
    131           Log.error $ "Discogs genre JSON error: " <> Exception.message err
    132           pure Nothing
    133         Right json -> do
    134           let
    135             genre = do
    136               obj <- toObject json
    137               results <- Object.lookup "results" obj >>= toArray
    138               firstResult <- results !! 0 >>= toObject
    139               genres <- Object.lookup "genres" firstResult >>= toArray
    140               genres !! 0 >>= toString
    141           pure genre
    142     _ -> do
    143       Log.warn "Discogs genre API request failed"
    144       pure Nothing
    145 
    146 fetchFallbackGenre :: String -> Array GenreSource -> Aff (Maybe String)
    147 fetchFallbackGenre slug = foldM trySource Nothing
    148   where
    149   trySource (Just g) _ = pure (Just g)
    150   trySource Nothing { name, enabled, fetch }
    151     | not enabled = pure Nothing
    152     | otherwise = do
    153         result <- fetch
    154         liftEffect $ case result of
    155           Just _ -> Metrics.incEnrichmentFetch slug name "found"
    156           Nothing -> Metrics.incEnrichmentFetch slug name "not_found"
    157         pure result
    158 
    159 enrichMetadata :: Connection -> UserConfig -> String -> Aff Unit
    160 enrichMetadata conn cfg slug = forever do
    161   unenrichedMbids <- getUnenrichedMbids conn 10
    162   emptyGenreMbids <- getEmptyGenreMbids conn 10
    163   let allMbids = unenrichedMbids <> emptyGenreMbids
    164 
    165   liftEffect $ Metrics.setEnrichmentQueueSize slug "unenriched" (length unenrichedMbids)
    166   liftEffect $ Metrics.setEnrichmentQueueSize slug "empty_genre" (length emptyGenreMbids)
    167 
    168   if null allMbids then
    169     delay (Milliseconds 60000.0)
    170   else do
    171     Log.info $ "Processing " <> show (length unenrichedMbids) <> " unenriched + " <> show (length emptyGenreMbids) <> " empty genre releases"
    172     artistReleaseMap <- getArtistReleasesByMbids conn allMbids
    173     for_ allMbids \mbid -> do
    174       delay (Milliseconds 1100.0)
    175       result <- try $ fetchMusicBrainzRelease mbid
    176       case result of
    177         Left err -> do
    178           Log.error $ "Enrichment error: " <> Exception.message err
    179           liftEffect $ Metrics.incEnrichmentFetch slug "musicbrainz" "error"
    180         Right Nothing -> do
    181           liftEffect $ Metrics.incEnrichmentFetch slug "musicbrainz" "retry"
    182           upsertReleaseMetadata conn mbid Nothing Nothing Nothing
    183           touchGenreCheckedAt conn mbid
    184         Right (Just mbdata) -> do
    185           liftEffect $ Metrics.incEnrichmentFetch slug "musicbrainz" "success"
    186           case mbdata.genre of
    187             Just _ ->
    188               upsertReleaseMetadata conn mbid mbdata.genre mbdata.label mbdata.year
    189             Nothing -> do
    190               let artistRelease = Object.lookup mbid artistReleaseMap
    191               case artistRelease of
    192                 Just { artist, release } -> do
    193                   let
    194                     sources =
    195                       [ { name: "lastfm", enabled: isJust cfg.lastfmApiKey, fetch: fetchLastfmGenre cfg.lastfmApiKey artist release }
    196                       , { name: "discogs", enabled: isJust cfg.discogsToken, fetch: fetchDiscogsGenre cfg.discogsToken artist release }
    197                       ]
    198                   finalGenre <- fetchFallbackGenre slug sources
    199                   upsertReleaseMetadata conn mbid finalGenre mbdata.label mbdata.year
    200                   case finalGenre of
    201                     Just genre ->
    202                       Log.info $ "Added fallback genre for " <> mbid <> ": " <> genre
    203                     Nothing -> do
    204                       Log.info $ "No genre found in any source for " <> mbid
    205                       touchGenreCheckedAt conn mbid
    206                 Nothing -> do
    207                   Log.warn $ "No artist/release info found for MBID " <> mbid <> ", cannot use fallback sources"
    208                   upsertReleaseMetadata conn mbid mbdata.genre mbdata.label mbdata.year
    209                   touchGenreCheckedAt conn mbid