commit 93f2e0d5acafce95f29d0a75420c3a99c4e3b55e
parent d01bb0b28dc69f2eac9d7733fdd7002575b6e420
Author: mtmn <miro@haravara.org>
Date: Wed, 22 Apr 2026 21:11:04 +0200
feat: doucple Main.purs to modules
Diffstat:
| A | src/Cosine.purs | | | 126 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | src/Cover.purs | | | 210 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| M | src/Main.purs | | | 490 | +++++-------------------------------------------------------------------------- |
| A | src/Metadata.purs | | | 209 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| M | test/Main.purs | | | 3 | ++- |
5 files changed, 577 insertions(+), 461 deletions(-)
diff --git a/src/Cosine.purs b/src/Cosine.purs
@@ -0,0 +1,126 @@
+module Cosine
+ ( fetchCosineSimilar
+ , serveSimilar
+ ) where
+
+import Prelude
+
+import Config (UserConfig)
+import Control.Monad.Error.Class (throwError)
+import Data.Array ((!!))
+import Data.Either (Either(..), hush)
+import Data.Argonaut (parseJson)
+import Data.Argonaut.Core (toArray, toObject, toString)
+import Data.Maybe (Maybe(..), fromMaybe)
+import Effect (Effect)
+import Effect.Aff (Aff, launchAff_, try)
+import Effect.Class (liftEffect)
+import Effect.Exception as Exception
+import Fetch (fetch, Method(GET))
+import Foreign.Object as Object
+import JSURI (encodeURIComponent)
+import Log as Log
+import Metrics as Metrics
+import Node.Encoding (Encoding(UTF8))
+import Node.HTTP.OutgoingMessage (setHeader, toWriteable)
+import Node.HTTP.ServerResponse (setStatusCode, toOutgoingMessage)
+import Node.HTTP.Types (ServerResponse)
+import Node.Stream (end, writeString)
+import Web.URL (URL)
+import Web.URL.URLSearchParams as URLSearchParams
+import Web.URL as URL
+
+type Response = ServerResponse
+
+getQueryParam :: String -> URL -> Maybe String
+getQueryParam key url = URLSearchParams.get key (URL.searchParams url)
+
+fetchCosineSimilar :: String -> UserConfig -> String -> Aff String
+fetchCosineSimilar slug cfg query = do
+ let apiKey = fromMaybe "" cfg.cosineApiKey
+ if apiKey == "" then do
+ Log.warn "cosineApiKey not configured for similar tracks"
+ liftEffect $ Metrics.incCosineRequest slug "not_configured"
+ pure "{\"data\":{\"similar_tracks\":[]},\"success\":true}"
+ else do
+ let headers = { "User-Agent": "corpus/1.0 +https://github.com/mtmn/corpus", "Authorization": "Bearer " <> apiKey }
+ let searchUrl = "https://cosine.club/api/v1/search?q=" <> (fromMaybe "" $ encodeURIComponent query) <> "&limit=1"
+ Log.info $ "Cosine Club: searching for: " <> query
+ searchResult <- try $ fetch searchUrl { method: GET, headers: headers }
+ case searchResult of
+ Left err -> do
+ liftEffect $ Metrics.incCosineRequest slug "error"
+ throwError err
+ Right searchRes ->
+ if searchRes.status == 429 then do
+ Log.warn "Cosine Club: rate limited on search"
+ liftEffect $ Metrics.incCosineRequest slug "rate_limited"
+ throwError (Exception.error "Rate limit exceeded")
+ else if searchRes.status /= 200 then do
+ Log.warn $ "Cosine Club: search returned " <> show searchRes.status
+ liftEffect $ Metrics.incCosineRequest slug "error"
+ throwError (Exception.error "Search API error")
+ else do
+ searchBody <- searchRes.text
+ let
+ mTrackId = do
+ json <- hush $ parseJson searchBody
+ obj <- toObject json
+ arr <- Object.lookup "data" obj >>= toArray
+ first <- arr !! 0
+ firstObj <- toObject first
+ Object.lookup "id" firstObj >>= toString
+ case mTrackId of
+ Nothing -> do
+ Log.info $ "Cosine Club: track not indexed: " <> query
+ liftEffect $ Metrics.incCosineRequest slug "not_indexed"
+ pure "{\"data\":{\"similar_tracks\":[]},\"success\":true}"
+ Just trackId -> do
+ let similarUrl = "https://cosine.club/api/v1/tracks/" <> trackId <> "/similar?limit=10"
+ Log.info $ "Cosine Club: fetching similar for ID " <> trackId
+ similarResult <- try $ fetch similarUrl { method: GET, headers: headers }
+ case similarResult of
+ Left err -> do
+ liftEffect $ Metrics.incCosineRequest slug "error"
+ throwError err
+ Right similarRes ->
+ if similarRes.status == 429 then do
+ Log.warn "Cosine Club: rate limited on similar"
+ liftEffect $ Metrics.incCosineRequest slug "rate_limited"
+ throwError (Exception.error "Rate limit exceeded")
+ else if similarRes.status /= 200 then do
+ Log.warn $ "Cosine Club: similar API returned " <> show similarRes.status
+ liftEffect $ Metrics.incCosineRequest slug "error"
+ throwError (Exception.error "Similar API error")
+ else do
+ liftEffect $ Metrics.incCosineRequest slug "success"
+ similarRes.text
+
+serveSimilar
+ :: (Response -> String -> Effect Unit)
+ -> (Response -> Int -> String -> String -> Effect Unit)
+ -> String
+ -> UserConfig
+ -> URL
+ -> Response
+ -> Effect Unit
+serveSimilar serveBadRequest serveError slug cfg url res = do
+ setHeader "Content-Type" "application/json" (toOutgoingMessage res)
+ launchAff_ do
+ let artist = fromMaybe "" (getQueryParam "artist" url)
+ let track = fromMaybe "" (getQueryParam "track" url)
+ if artist == "" || track == "" then
+ liftEffect $ serveBadRequest res "Artist and track parameters are required"
+ else do
+ let query = artist <> " - " <> track
+ result <- try $ fetchCosineSimilar slug cfg query
+ case result of
+ Left err -> do
+ Log.error $ "Cosine Club API error: " <> Exception.message err
+ liftEffect $ serveError res 502 "Bad Gateway" "Failed to fetch similar tracks"
+ Right responseBody ->
+ liftEffect $ do
+ setStatusCode 200 res
+ let w = toWriteable (toOutgoingMessage res)
+ void $ writeString w UTF8 responseBody
+ end w
diff --git a/src/Cover.purs b/src/Cover.purs
@@ -0,0 +1,210 @@
+module Cover
+ ( CoverSource
+ , sanitizeKey
+ , fetchLastfmCoverUrl
+ , fetchDiscogsCoverUrl
+ , coverSources
+ , serveCover
+ ) where
+
+import Prelude
+
+import Config (S3Config, UserConfig, s3ConfigFromUser)
+import S3 (existsInS3, getS3Url, uploadToS3)
+import Control.Monad.Error.Class (throwError)
+import Data.Array ((!!))
+import Data.Either (Either(..))
+import Data.Foldable (foldM)
+import Data.Map as Map
+import Data.Maybe (Maybe(..), fromMaybe)
+import Data.String.CaseInsensitive (CaseInsensitiveString(..))
+import Data.String.Regex (replace, parseFlags)
+import Data.String.Regex.Unsafe (unsafeRegex)
+import Effect (Effect)
+import Effect.Aff (Aff, forkAff, launchAff_, try)
+import Effect.Class (liftEffect)
+import Effect.Exception as Exception
+import Fetch (fetch, Method(GET))
+import Fetch.Argonaut.Json (fromJson)
+import Foreign.Object as Object
+import Data.Argonaut.Core (toArray, toObject, toString)
+import Image (convertToAvif)
+import JSURI (encodeURIComponent)
+import Log as Log
+import Metrics as Metrics
+import Node.Buffer (fromArrayBuffer)
+import Node.HTTP.OutgoingMessage (setHeader, toWriteable)
+import Node.HTTP.ServerResponse (setStatusCode, toOutgoingMessage)
+import Node.HTTP.Types (ServerResponse)
+import Node.Stream (end, write)
+import S3 (existsInS3, getS3Url, uploadToS3)
+import Unsafe.Coerce (unsafeCoerce)
+import Web.URL (URL)
+import Web.URL as URL
+import Web.URL.URLSearchParams as URLSearchParams
+
+type Response = ServerResponse
+
+type CoverSource =
+ { name :: String
+ , s3Key :: String
+ , findUrl :: Aff (Maybe String)
+ }
+
+sanitizeKey :: String -> String
+sanitizeKey = replace re1 "_" >>> replace re2 "_"
+ where
+ re1 = unsafeRegex "[^a-z0-9.-]" (parseFlags "gi")
+ re2 = unsafeRegex "_{2,}" (parseFlags "g")
+
+getQueryParam :: String -> URL -> Maybe String
+getQueryParam key url = URLSearchParams.get key (URL.searchParams url)
+
+fetchLastfmCoverUrl :: UserConfig -> String -> String -> Aff (Maybe String)
+fetchLastfmCoverUrl cfg artist release = case cfg.lastfmApiKey of
+ Nothing ->
+ pure Nothing
+ Just k -> do
+ let
+ searchUrl = "https://ws.audioscrobbler.com/2.0/?method=album.getinfo&artist="
+ <> (fromMaybe "" $ encodeURIComponent artist)
+ <> "&album="
+ <> (fromMaybe "" $ encodeURIComponent release)
+ <> "&format=json&api_key="
+ <> k
+ Log.info $ "Searching Last.fm for: " <> artist <> " - " <> release
+ result <- try $ fetch searchUrl { method: GET }
+ case result of
+ Right fr | fr.status == 200 -> do
+ json <- fromJson fr.json
+ pure $ do
+ obj <- toObject json
+ album <- Object.lookup "album" obj >>= toObject
+ images <- Object.lookup "image" album >>= toArray
+ imgObj <- images !! 2 >>= toObject
+ u <- Object.lookup "#text" imgObj >>= toString
+ if u == "" then Nothing else Just u
+ _ ->
+ pure Nothing
+
+fetchDiscogsCoverUrl :: UserConfig -> String -> String -> Aff (Maybe String)
+fetchDiscogsCoverUrl cfg artist release = case cfg.discogsToken of
+ Nothing ->
+ pure Nothing
+ Just t -> do
+ let
+ queryStr = artist <> " " <> release
+ searchUrl = "https://api.discogs.com/database/search?q="
+ <> (fromMaybe "" $ encodeURIComponent queryStr)
+ <> "&type=release&per_page=1"
+ Log.info $ "Searching Discogs for: " <> queryStr
+ result <- try $ fetch searchUrl { method: GET, headers: { "User-Agent": "corpus/1.0 +https://github.com/mtmn/corpus", "Authorization": "Discogs token=" <> t } }
+ case result of
+ Right fr | fr.status == 200 -> do
+ json <- fromJson fr.json
+ pure $ do
+ obj <- toObject json
+ results <- Object.lookup "results" obj >>= toArray
+ firstResult <- results !! 0 >>= toObject
+ Object.lookup "cover_image" firstResult >>= toString
+ _ ->
+ pure Nothing
+
+coverSources :: String -> String -> String -> UserConfig -> Array CoverSource
+coverSources mbid artist release cfg =
+ let
+ safeArtist = sanitizeKey artist
+ safeRelease = sanitizeKey release
+ in
+ [ { name: "caa"
+ , s3Key: "covers/caa/" <> sanitizeKey mbid <> ".avif"
+ , findUrl:
+ if mbid == "" then pure Nothing
+ else pure $ Just $ "https://coverartarchive.org/release/" <> mbid <> "/front-250"
+ }
+ , { name: "lastfm"
+ , s3Key: "covers/lastfm/" <> safeArtist <> "-" <> safeRelease <> ".avif"
+ , findUrl:
+ if artist == "" || release == "" then pure Nothing
+ else fetchLastfmCoverUrl cfg artist release
+ }
+ , { name: "discogs"
+ , s3Key: "covers/discogs/" <> safeArtist <> "-" <> safeRelease <> ".avif"
+ , findUrl:
+ if artist == "" || release == "" then pure Nothing
+ else fetchDiscogsCoverUrl cfg artist release
+ }
+ ]
+
+serveCover :: (Response -> Effect Unit) -> UserConfig -> String -> URL -> Response -> Aff Unit
+serveCover serveNotFound cfg slug url res = do
+ let
+ mbid = fromMaybe "" (getQueryParam "mbid" url)
+ artist = fromMaybe "" (getQueryParam "artist" url)
+ release = fromMaybe "" (getQueryParam "release" url)
+ s3cfg = s3ConfigFromUser cfg
+
+ served <- foldM (trySource s3cfg) false (coverSources mbid artist release cfg)
+ unless served $ liftEffect $ serveNotFound res
+
+ where
+ trySource _ true _ = pure true
+ trySource s3cfg false { name, s3Key, findUrl } = do
+ cached <- checkS3 s3cfg s3Key
+ if cached then do
+ Log.info $ "Serving " <> name <> " cover from S3: " <> s3Key
+ liftEffect $ Metrics.incCoverRequest slug name "s3_hit"
+ liftEffect $ serveS3Redirect s3cfg s3Key res
+ pure true
+ else do
+ mUrl <- findUrl
+ case mUrl of
+ Nothing ->
+ pure false
+ Just urlStr -> do
+ success <- tryProxyAndCache s3cfg urlStr s3Key res
+ liftEffect $
+ if success then Metrics.incCoverRequest slug name "fetch"
+ else Metrics.incCoverRequest slug name "miss"
+ pure success
+
+ checkS3 s3cfg s3Key
+ | not cfg.coverCacheEnabled = pure false
+ | otherwise = do
+ result <- try $ existsInS3 s3cfg s3Key
+ pure $ case result of
+ Right b -> b
+ Left _ -> false
+
+ serveS3Redirect s3cfg s3Key response = do
+ setStatusCode 302 response
+ setHeader "Location" (getS3Url s3cfg s3Key) (toOutgoingMessage response)
+ end (toWriteable (toOutgoingMessage response))
+
+ tryProxyAndCache s3cfg urlStr s3Key response = do
+ fetchResult <- try $ fetch urlStr { method: GET }
+ case fetchResult of
+ Right fr | fr.status == 200 -> do
+ let
+ isAvif = case Map.lookup (CaseInsensitiveString "content-type") fr.headers of
+ Just ct | ct == "image/avif" -> true
+ _ -> false
+ Log.info $ "caching image (" <> (if isAvif then "already avif" else "needs conversion") <> "): " <> urlStr
+ buf <- fr.arrayBuffer
+ avifBuf <- if isAvif then pure buf else convertToAvif buf
+ liftEffect $ do
+ setStatusCode fr.status response
+ setHeader "Content-Type" "image/avif" (toOutgoingMessage response)
+ setHeader "Cache-Control" "public, max-age=86400" (toOutgoingMessage response)
+ let writer = toWriteable (toOutgoingMessage response)
+ nativeBuf <- fromArrayBuffer avifBuf
+ void $ write writer nativeBuf
+ end writer
+ when cfg.coverCacheEnabled $ void $ forkAff $ do
+ uploadResult <- try $ uploadToS3 s3cfg s3Key (unsafeCoerce avifBuf) "image/avif"
+ case uploadResult of
+ Right _ -> Log.info $ "Cached to S3: " <> s3Key
+ Left err -> Log.error $ "S3 upload failed: " <> Exception.message err
+ pure true
+ _ ->
+ pure false
diff --git a/src/Main.purs b/src/Main.purs
@@ -21,9 +21,9 @@ import Node.Stream (end, write, writeString)
import Node.Stream.Aff (readableToStringUtf8)
import Node.Encoding (Encoding(UTF8))
import Node.Net.Server (listenTcp, listeningH)
-import Node.Buffer (fromArrayBuffer)
-import Data.Either (Either(..), hush)
-import Control.Monad.Error.Class (throwError)
+
+import Data.Either (Either(..))
+
import Effect.Exception as Exception
import Effect.Aff (Aff, launchAff_, makeAff, nonCanceler, try, delay, forkAff, joinFiber, killFiber, Fiber)
import Effect.Aff.AVar (AVar)
@@ -32,34 +32,34 @@ import Unsafe.Coerce (unsafeCoerce)
import Node.FS.Aff as FSA
import Fetch (fetch, Method(GET))
import Fetch.Argonaut.Json (fromJson)
-import Data.Map as Map
-import Data.String.CaseInsensitive (CaseInsensitiveString(..))
-import Data.Maybe (Maybe(..), fromMaybe, isJust)
+
+import Data.Maybe (Maybe(..), fromMaybe)
import JSURI (encodeURIComponent)
import Foreign.Object as Object
import Data.Argonaut (decodeJson, encodeJson, parseJson)
import Data.Argonaut.Core (Json, toObject, toArray, toString, stringify)
-import Data.Array ((!!), length, null, mapMaybe, find)
+import Data.Array (find, length, mapMaybe, null)
import Data.Tuple (Tuple(..))
import Data.Foldable (for_, foldM, traverse_)
+import Cover (serveCover)
+import Cosine (serveSimilar)
+import Metadata (enrichMetadata)
import Data.Traversable (traverse)
-import Db (Connection, FilterField(..), connect, initDb, upsertScrobble, getScrobbles, checkExists, getOldestTs, initReleaseMetadata, getUnenrichedMbids, getEmptyGenreMbids, getArtistReleasesByMbids, upsertReleaseMetadata, touchGenreCheckedAt, getStats, ping, backupDb, withTransaction)
+import Db (Connection, FilterField(..), backupDb, checkExists, connect, getOldestTs, getScrobbles, getStats, initDb, initReleaseMetadata, ping, upsertScrobble, withTransaction)
import Types (Listen(..), ListenBrainzResponse(..), MbidMapping(..), Payload(..), TrackMetadata(..))
import Control.Monad.Rec.Class (forever)
import Data.Time.Duration (Milliseconds(..))
import Data.Int (fromString, toNumber)
import Data.String (Pattern(..), stripPrefix)
import Node.Process (lookupEnv)
-import Data.String.Common (split) as String
+
import Data.String.Regex (replace, parseFlags)
import Data.String.Regex.Unsafe (unsafeRegex)
-import S3 (existsInS3, uploadToS3, getS3Url)
import Effect.Aff.Retry (RetryStatus(..), exponentialBackoff, limitRetries, recovering)
import Web.URL (URL)
import Web.URL as URL
import Web.URL.URLSearchParams as URLSearchParams
import Templates (indexHtml)
-import Image (convertToAvif)
-- Types
type Request = IncomingMessage IMServer
@@ -374,9 +374,9 @@ routeRequest metricsEnabled contexts url path allUsers res = liftEffect $ case p
"/stats" ->
withUser url \ctx -> serveStats ctx.conn url res
"/cover" ->
- withUser url \ctx -> serveCover ctx.config ctx.slug url res
+ withUser url \ctx -> launchAff_ $ serveCover serveNotFound ctx.config ctx.slug url res
"/similar" ->
- withUser url \ctx -> serveSimilar ctx.slug ctx.config url res
+ withUser url \ctx -> serveSimilar serveBadRequest serveError ctx.slug ctx.config url res
"/healthz" ->
withUser url \ctx -> serveHealthz ctx.conn res
_ ->
@@ -445,170 +445,6 @@ parseFilterField "genre" = Just FilterGenre
parseFilterField "track" = Just FilterTrack
parseFilterField _ = Nothing
-sanitizeKey :: String -> String
-sanitizeKey = replace re1 "_" >>> replace re2 "_"
- where
- re1 = unsafeRegex "[^a-z0-9.-]" (parseFlags "gi")
- re2 = unsafeRegex "_{2,}" (parseFlags "g")
-
--- Fetch the Last.fm image URL for an artist/release (no caching, no serving).
-fetchLastfmCoverUrl :: UserConfig -> String -> String -> Aff (Maybe String)
-fetchLastfmCoverUrl cfg artist release = case cfg.lastfmApiKey of
- Nothing ->
- pure Nothing
- Just k -> do
- let
- searchUrl = "https://ws.audioscrobbler.com/2.0/?method=album.getinfo&artist="
- <> (fromMaybe "" $ encodeURIComponent artist)
- <> "&album="
- <> (fromMaybe "" $ encodeURIComponent release)
- <> "&format=json&api_key="
- <> k
- Log.info $ "Searching Last.fm for: " <> artist <> " - " <> release
- result <- try $ fetch searchUrl { method: GET }
- case result of
- Right fr | fr.status == 200 -> do
- json <- fromJson fr.json
- pure $ do
- obj <- toObject json
- album <- Object.lookup "album" obj >>= toObject
- images <- Object.lookup "image" album >>= toArray
- imgObj <- images !! 2 >>= toObject
- u <- Object.lookup "#text" imgObj >>= toString
- if u == "" then Nothing else Just u
- _ ->
- pure Nothing
-
--- Fetch the Discogs image URL for an artist/release (no caching, no serving).
-fetchDiscogsCoverUrl :: UserConfig -> String -> String -> Aff (Maybe String)
-fetchDiscogsCoverUrl cfg artist release = case cfg.discogsToken of
- Nothing ->
- pure Nothing
- Just t -> do
- let
- queryStr = artist <> " " <> release
- searchUrl = "https://api.discogs.com/database/search?q="
- <> (fromMaybe "" $ encodeURIComponent queryStr)
- <> "&type=release&per_page=1"
- Log.info $ "Searching Discogs for: " <> queryStr
- result <- try $ fetch searchUrl { method: GET, headers: { "User-Agent": "corpus/1.0 +https://github.com/mtmn/corpus", "Authorization": "Discogs token=" <> t } }
- case result of
- Right fr | fr.status == 200 -> do
- json <- fromJson fr.json
- pure $ do
- obj <- toObject json
- results <- Object.lookup "results" obj >>= toArray
- firstResult <- results !! 0 >>= toObject
- Object.lookup "cover_image" firstResult >>= toString
- _ ->
- pure Nothing
-
-type CoverSource =
- { name :: String
- , s3Key :: String
- , findUrl :: Aff (Maybe String)
- }
-
-coverSources :: String -> String -> String -> UserConfig -> Array CoverSource
-coverSources mbid artist release cfg =
- let
- safeArtist = sanitizeKey artist
- safeRelease = sanitizeKey release
- in
- [ { name: "caa"
- , s3Key: "covers/caa/" <> sanitizeKey mbid <> ".avif"
- , findUrl:
- if mbid == "" then pure Nothing
- else pure $ Just $ "https://coverartarchive.org/release/" <> mbid <> "/front-250"
- }
- , { name: "lastfm"
- , s3Key: "covers/lastfm/" <> safeArtist <> "-" <> safeRelease <> ".avif"
- , findUrl:
- if artist == "" || release == "" then pure Nothing
- else fetchLastfmCoverUrl cfg artist release
- }
- , { name: "discogs"
- , s3Key: "covers/discogs/" <> safeArtist <> "-" <> safeRelease <> ".avif"
- , findUrl:
- if artist == "" || release == "" then pure Nothing
- else fetchDiscogsCoverUrl cfg artist release
- }
- ]
-
-serveCover :: UserConfig -> String -> URL -> Response -> Effect Unit
-serveCover cfg slug url res = launchAff_ do
- let
- mbid = fromMaybe "" (getQueryParam "mbid" url)
- artist = fromMaybe "" (getQueryParam "artist" url)
- release = fromMaybe "" (getQueryParam "release" url)
- s3cfg = s3ConfigFromUser cfg
-
- served <- foldM (trySource s3cfg) false (coverSources mbid artist release cfg)
- unless served $ liftEffect $ serveNotFound res
-
- where
- trySource _ true _ = pure true
- trySource s3cfg false { name, s3Key, findUrl } = do
- cached <- checkS3 s3cfg s3Key
- if cached then do
- Log.info $ "Serving " <> name <> " cover from S3: " <> s3Key
- liftEffect $ Metrics.incCoverRequest slug name "s3_hit"
- serveS3 s3cfg s3Key res
- pure true
- else do
- mUrl <- findUrl
- case mUrl of
- Nothing ->
- pure false
- Just urlStr -> do
- success <- tryProxyAndCache s3cfg urlStr s3Key res
- liftEffect $
- if success then Metrics.incCoverRequest slug name "fetch"
- else Metrics.incCoverRequest slug name "miss"
- pure success
-
- checkS3 s3cfg s3Key
- | not cfg.coverCacheEnabled = pure false
- | otherwise = do
- result <- try $ existsInS3 s3cfg s3Key
- pure $ case result of
- Right b -> b
- Left _ -> false
-
- serveS3 s3cfg s3Key response = liftEffect $ do
- setStatusCode 302 response
- setHeader "Location" (getS3Url s3cfg s3Key) (toOutgoingMessage response)
- end (toWriteable (toOutgoingMessage response))
-
- tryProxyAndCache s3cfg urlStr s3Key response = do
- fetchResult <- try $ fetch urlStr { method: GET }
- case fetchResult of
- Right fr | fr.status == 200 -> do
- let
- isAvif = case Map.lookup (CaseInsensitiveString "content-type") fr.headers of
- Just ct | ct == "image/avif" -> true
- _ -> false
-
- Log.info $ "caching image (" <> (if isAvif then "already avif" else "needs conversion") <> "): " <> urlStr
- buf <- fr.arrayBuffer
- avifBuf <- if isAvif then pure buf else convertToAvif buf
- liftEffect $ do
- setStatusCode fr.status response
- setHeader "Content-Type" "image/avif" (toOutgoingMessage response)
- setHeader "Cache-Control" "public, max-age=86400" (toOutgoingMessage response)
- let writer = toWriteable (toOutgoingMessage response)
- nativeBuf <- fromArrayBuffer avifBuf
- void $ write writer nativeBuf
- end writer
- when cfg.coverCacheEnabled $ void $ forkAff $ do
- uploadResult <- try $ uploadToS3 s3cfg s3Key (unsafeCoerce avifBuf) "image/avif"
- case uploadResult of
- Right _ -> Log.info $ "Cached to S3: " <> s3Key
- Left err -> Log.error $ "S3 upload failed: " <> Exception.message err
- pure true
- _ ->
- pure false
-
serveProxy :: Connection -> URL -> Response -> Effect Unit
serveProxy db url res = do
setHeader "Content-Type" "application/json" (toOutgoingMessage res)
@@ -632,6 +468,23 @@ serveProxy db url res = do
void $ writeString w UTF8 responseBody
end w
+serveStats :: Connection -> URL -> Response -> Effect Unit
+serveStats db url res = do
+ setHeader "Content-Type" "application/json" (toOutgoingMessage res)
+ launchAff_ do
+ let period = getQueryParam "period" url
+ let section = getQueryParam "section" url
+ let safeDate = map (replace (unsafeRegex "[^0-9\\-]" (parseFlags "g")) "")
+ let mFrom = safeDate (getQueryParam "from" url)
+ let mTo = safeDate (getQueryParam "to" url)
+ stats <- getStats db period mFrom mTo section
+ let responseBody = stringify $ encodeJson stats
+ liftEffect $ do
+ setStatusCode 200 res
+ let w = toWriteable (toOutgoingMessage res)
+ void $ writeString w UTF8 responseBody
+ end w
+
serveAsset :: String -> String -> Response -> Effect Unit
serveAsset contentType path res = do
setHeader "Content-Type" contentType (toOutgoingMessage res)
@@ -695,289 +548,6 @@ serveError res statusCode statusName message = do
void $ writeString w UTF8 (statusName <> ": " <> message)
end w
-fetchCosineSimilar :: String -> UserConfig -> String -> Aff String
-fetchCosineSimilar slug cfg query = do
- let apiKey = fromMaybe "" cfg.cosineApiKey
- if apiKey == "" then do
- Log.warn "cosineApiKey not configured for similar tracks"
- liftEffect $ Metrics.incCosineRequest slug "not_configured"
- pure "{\"data\":{\"similar_tracks\":[]},\"success\":true}"
- else do
- let headers = { "User-Agent": "corpus/1.0 +https://github.com/mtmn/corpus", "Authorization": "Bearer " <> apiKey }
- let searchUrl = "https://cosine.club/api/v1/search?q=" <> (fromMaybe "" $ encodeURIComponent query) <> "&limit=1"
- Log.info $ "Cosine Club: searching for: " <> query
- searchResult <- try $ fetch searchUrl { method: GET, headers: headers }
- case searchResult of
- Left err -> do
- liftEffect $ Metrics.incCosineRequest slug "error"
- throwError err
- Right searchRes ->
- if searchRes.status == 429 then do
- Log.warn "Cosine Club: rate limited on search"
- liftEffect $ Metrics.incCosineRequest slug "rate_limited"
- throwError (Exception.error "Rate limit exceeded")
- else if searchRes.status /= 200 then do
- Log.warn $ "Cosine Club: search returned " <> show searchRes.status
- liftEffect $ Metrics.incCosineRequest slug "error"
- throwError (Exception.error "Search API error")
- else do
- searchBody <- searchRes.text
- let
- mTrackId = do
- json <- hush $ parseJson searchBody
- obj <- toObject json
- arr <- Object.lookup "data" obj >>= toArray
- first <- arr !! 0
- firstObj <- toObject first
- Object.lookup "id" firstObj >>= toString
- case mTrackId of
- Nothing -> do
- Log.info $ "Cosine Club: track not indexed: " <> query
- liftEffect $ Metrics.incCosineRequest slug "not_indexed"
- pure "{\"data\":{\"similar_tracks\":[]},\"success\":true}"
- Just trackId -> do
- let similarUrl = "https://cosine.club/api/v1/tracks/" <> trackId <> "/similar?limit=10"
- Log.info $ "Cosine Club: fetching similar for ID " <> trackId
- similarResult <- try $ fetch similarUrl { method: GET, headers: headers }
- case similarResult of
- Left err -> do
- liftEffect $ Metrics.incCosineRequest slug "error"
- throwError err
- Right similarRes ->
- if similarRes.status == 429 then do
- Log.warn "Cosine Club: rate limited on similar"
- liftEffect $ Metrics.incCosineRequest slug "rate_limited"
- throwError (Exception.error "Rate limit exceeded")
- else if similarRes.status /= 200 then do
- Log.warn $ "Cosine Club: similar API returned " <> show similarRes.status
- liftEffect $ Metrics.incCosineRequest slug "error"
- throwError (Exception.error "Similar API error")
- else do
- liftEffect $ Metrics.incCosineRequest slug "success"
- similarRes.text
-
-serveStats :: Connection -> URL -> Response -> Effect Unit
-serveStats db url res = do
- setHeader "Content-Type" "application/json" (toOutgoingMessage res)
- launchAff_ do
- let period = getQueryParam "period" url
- let section = getQueryParam "section" url
- let safeDate = map (replace (unsafeRegex "[^0-9\\-]" (parseFlags "g")) "")
- let mFrom = safeDate (getQueryParam "from" url)
- let mTo = safeDate (getQueryParam "to" url)
- stats <- getStats db period mFrom mTo section
- let responseBody = stringify $ encodeJson stats
- liftEffect $ do
- setStatusCode 200 res
- let w = toWriteable (toOutgoingMessage res)
- void $ writeString w UTF8 responseBody
- end w
-
-serveSimilar :: String -> UserConfig -> URL -> Response -> Effect Unit
-serveSimilar slug cfg url res = do
- setHeader "Content-Type" "application/json" (toOutgoingMessage res)
- launchAff_ do
- let artist = fromMaybe "" (getQueryParam "artist" url)
- let track = fromMaybe "" (getQueryParam "track" url)
- if artist == "" || track == "" then
- liftEffect $ serveBadRequest res "Artist and track parameters are required"
- else do
- let query = artist <> " - " <> track
- result <- try $ fetchCosineSimilar slug cfg query
-
- case result of
- Left err -> do
- Log.error $ "Cosine Club API error: " <> Exception.message err
- liftEffect $ serveError res 502 "Bad Gateway" "Failed to fetch similar tracks"
- Right responseBody -> do
- 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": "corpus/1.0 +https://github.com/mtmn/corpus" } }
- 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 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
- 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
- String.split (Pattern "-") dateStr !! 0 >>= fromString
- Log.info $ "Enriched " <> mbid <> ": genre=" <> show genre <> " label=" <> show label <> " year=" <> show year
-
- 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
- pure $ Just { genre: Nothing, label: Nothing, year: Nothing }
- Right fr -> do
- Log.warn $ "MusicBrainz " <> show fr.status <> " for " <> mbid <> ", will retry"
- pure Nothing
-
--- Explicit apiKey parameter — no env read.
-fetchLastfmGenre :: Maybe String -> String -> String -> Aff (Maybe String)
-fetchLastfmGenre Nothing _ _ = do
- Log.warn "lastfmApiKey not configured for genre fallback"
- pure Nothing
-fetchLastfmGenre (Just k) artist release = do
- let searchUrl = "https://ws.audioscrobbler.com/2.0/?method=album.getinfo&artist=" <> (fromMaybe "" $ encodeURIComponent artist) <> "&album=" <> (fromMaybe "" $ encodeURIComponent release) <> "&format=json" <> "&api_key=" <> k
- 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
-
--- Explicit token parameter — no env read.
-fetchDiscogsGenre :: Maybe String -> String -> String -> Aff (Maybe String)
-fetchDiscogsGenre Nothing _ _ = do
- Log.warn "discogsToken not configured for genre fallback"
- pure Nothing
-fetchDiscogsGenre (Just t) artist release = do
- let queryStr = artist <> " " <> release
- let searchUrl = "https://api.discogs.com/database/search?q=" <> (fromMaybe "" $ encodeURIComponent queryStr) <> "&type=release&per_page=1"
- Log.info $ "Fetching Discogs genre for: " <> queryStr
- result <- try $ fetch searchUrl { method: GET, headers: { "User-Agent": "corpus/1.0 +https://github.com/mtmn/corpus", "Authorization": "Discogs token=" <> t } }
- 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
-
-type GenreSource =
- { name :: String
- , enabled :: Boolean
- , fetch :: Aff (Maybe String)
- }
-
--- Try each source in order, stopping at the first that returns Just.
--- Records found/not_found metrics only for sources that are enabled and queried.
-fetchFallbackGenre :: String -> Array GenreSource -> Aff (Maybe String)
-fetchFallbackGenre slug = foldM trySource Nothing
- where
- trySource (Just g) _ = pure (Just g)
- trySource Nothing { name, enabled, fetch }
- | not enabled = pure Nothing
- | otherwise = do
- result <- fetch
- liftEffect $ case result of
- Just _ -> Metrics.incEnrichmentFetch slug name "found"
- Nothing -> Metrics.incEnrichmentFetch slug name "not_found"
- pure result
-
-enrichMetadata :: Connection -> UserConfig -> String -> Aff Unit
-enrichMetadata conn cfg slug = forever do
- unenrichedMbids <- getUnenrichedMbids conn 10
- emptyGenreMbids <- getEmptyGenreMbids conn 10
- let allMbids = unenrichedMbids <> emptyGenreMbids
-
- liftEffect $ Metrics.setEnrichmentQueueSize slug "unenriched" (length unenrichedMbids)
- liftEffect $ Metrics.setEnrichmentQueueSize slug "empty_genre" (length emptyGenreMbids)
-
- if null allMbids then
- delay (Milliseconds 60000.0)
- else do
- Log.info $ "Processing " <> show (length unenrichedMbids) <> " unenriched + " <> show (length emptyGenreMbids) <> " empty genre releases"
- artistReleaseMap <- getArtistReleasesByMbids conn allMbids
- for_ allMbids \mbid -> do
- delay (Milliseconds 1100.0)
- result <- try $ fetchMusicBrainzRelease mbid
- case result of
- Left err -> do
- Log.error $ "Enrichment error: " <> Exception.message err
- liftEffect $ Metrics.incEnrichmentFetch slug "musicbrainz" "error"
- Right Nothing -> do
- liftEffect $ Metrics.incEnrichmentFetch slug "musicbrainz" "retry"
- upsertReleaseMetadata conn mbid Nothing Nothing Nothing
- touchGenreCheckedAt conn mbid
- Right (Just mbdata) -> do
- liftEffect $ Metrics.incEnrichmentFetch slug "musicbrainz" "success"
- case mbdata.genre of
- Just _ ->
- upsertReleaseMetadata conn mbid mbdata.genre mbdata.label mbdata.year
- Nothing -> do
- let artistRelease = Object.lookup mbid artistReleaseMap
- case artistRelease of
- Just { artist, release } -> do
- let
- sources =
- [ { name: "lastfm", enabled: isJust cfg.lastfmApiKey, fetch: fetchLastfmGenre cfg.lastfmApiKey artist release }
- , { name: "discogs", enabled: isJust cfg.discogsToken, fetch: fetchDiscogsGenre cfg.discogsToken artist release }
- ]
- finalGenre <- fetchFallbackGenre slug sources
- upsertReleaseMetadata conn mbid finalGenre mbdata.label mbdata.year
- case finalGenre of
- Just genre ->
- Log.info $ "Added fallback genre 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
-
--- Initialise one user: connect DB, start sync loops, return a UserContext.
startUser :: UserEntry -> Aff UserContext
startUser { slug, name, config } = do
Log.info $ "Starting user: " <> if slug == "" then "(root)" else slug
diff --git a/src/Metadata.purs b/src/Metadata.purs
@@ -0,0 +1,208 @@
+module Metadata
+ ( MbData
+ , GenreSource
+ , fetchMusicBrainzRelease
+ , fetchLastfmGenre
+ , fetchDiscogsGenre
+ , fetchFallbackGenre
+ , enrichMetadata
+ ) where
+
+import Prelude
+
+import Config (UserConfig)
+import Control.Monad.Rec.Class (forever)
+import Data.Array ((!!), length, null)
+import Data.Either (Either(..))
+import Data.Foldable (foldM, for_)
+import Data.Int (fromString)
+import Data.Maybe (Maybe(..), fromMaybe, isJust)
+import Data.String (Pattern(..))
+import Data.String.Common as String
+import Data.Time.Duration (Milliseconds(..))
+import Data.Argonaut.Core (toArray, toObject, toString)
+import Db (Connection, getArtistReleasesByMbids, getEmptyGenreMbids, getUnenrichedMbids, touchGenreCheckedAt, upsertReleaseMetadata)
+import Effect.Aff (Aff, delay, try)
+import Effect.Class (liftEffect)
+import Effect.Exception as Exception
+import Fetch (fetch, Method(GET))
+import Fetch.Argonaut.Json (fromJson)
+import Foreign.Object as Object
+import JSURI (encodeURIComponent)
+import Log as Log
+import Metrics as Metrics
+
+type MbData = { genre :: Maybe String, label :: Maybe String, year :: Maybe Int }
+
+type GenreSource =
+ { name :: String
+ , enabled :: Boolean
+ , fetch :: Aff (Maybe String)
+ }
+
+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": "corpus/1.0 +https://github.com/mtmn/corpus" } }
+ 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 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
+ 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
+ String.split (Pattern "-") dateStr !! 0 >>= fromString
+ Log.info $ "Enriched " <> mbid <> ": genre=" <> show genre <> " label=" <> show label <> " year=" <> show year
+ 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
+ pure $ Just { genre: Nothing, label: Nothing, year: Nothing }
+ Right fr -> do
+ Log.warn $ "MusicBrainz " <> show fr.status <> " for " <> mbid <> ", will retry"
+ pure Nothing
+
+fetchLastfmGenre :: Maybe String -> String -> String -> Aff (Maybe String)
+fetchLastfmGenre Nothing _ _ = do
+ Log.warn "lastfmApiKey not configured for genre fallback"
+ pure Nothing
+fetchLastfmGenre (Just k) artist release = do
+ let searchUrl = "https://ws.audioscrobbler.com/2.0/?method=album.getinfo&artist=" <> (fromMaybe "" $ encodeURIComponent artist) <> "&album=" <> (fromMaybe "" $ encodeURIComponent release) <> "&format=json" <> "&api_key=" <> k
+ 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 :: Maybe String -> String -> String -> Aff (Maybe String)
+fetchDiscogsGenre Nothing _ _ = do
+ Log.warn "discogsToken not configured for genre fallback"
+ pure Nothing
+fetchDiscogsGenre (Just t) artist release = do
+ let queryStr = artist <> " " <> release
+ let searchUrl = "https://api.discogs.com/database/search?q=" <> (fromMaybe "" $ encodeURIComponent queryStr) <> "&type=release&per_page=1"
+ Log.info $ "Fetching Discogs genre for: " <> queryStr
+ result <- try $ fetch searchUrl { method: GET, headers: { "User-Agent": "corpus/1.0 +https://github.com/mtmn/corpus", "Authorization": "Discogs token=" <> t } }
+ 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
+
+fetchFallbackGenre :: String -> Array GenreSource -> Aff (Maybe String)
+fetchFallbackGenre slug = foldM trySource Nothing
+ where
+ trySource (Just g) _ = pure (Just g)
+ trySource Nothing { name, enabled, fetch }
+ | not enabled = pure Nothing
+ | otherwise = do
+ result <- fetch
+ liftEffect $ case result of
+ Just _ -> Metrics.incEnrichmentFetch slug name "found"
+ Nothing -> Metrics.incEnrichmentFetch slug name "not_found"
+ pure result
+
+enrichMetadata :: Connection -> UserConfig -> String -> Aff Unit
+enrichMetadata conn cfg slug = forever do
+ unenrichedMbids <- getUnenrichedMbids conn 10
+ emptyGenreMbids <- getEmptyGenreMbids conn 10
+ let allMbids = unenrichedMbids <> emptyGenreMbids
+
+ liftEffect $ Metrics.setEnrichmentQueueSize slug "unenriched" (length unenrichedMbids)
+ liftEffect $ Metrics.setEnrichmentQueueSize slug "empty_genre" (length emptyGenreMbids)
+
+ if null allMbids then
+ delay (Milliseconds 60000.0)
+ else do
+ Log.info $ "Processing " <> show (length unenrichedMbids) <> " unenriched + " <> show (length emptyGenreMbids) <> " empty genre releases"
+ artistReleaseMap <- getArtistReleasesByMbids conn allMbids
+ for_ allMbids \mbid -> do
+ delay (Milliseconds 1100.0)
+ result <- try $ fetchMusicBrainzRelease mbid
+ case result of
+ Left err -> do
+ Log.error $ "Enrichment error: " <> Exception.message err
+ liftEffect $ Metrics.incEnrichmentFetch slug "musicbrainz" "error"
+ Right Nothing -> do
+ liftEffect $ Metrics.incEnrichmentFetch slug "musicbrainz" "retry"
+ upsertReleaseMetadata conn mbid Nothing Nothing Nothing
+ touchGenreCheckedAt conn mbid
+ Right (Just mbdata) -> do
+ liftEffect $ Metrics.incEnrichmentFetch slug "musicbrainz" "success"
+ case mbdata.genre of
+ Just _ ->
+ upsertReleaseMetadata conn mbid mbdata.genre mbdata.label mbdata.year
+ Nothing -> do
+ let artistRelease = Object.lookup mbid artistReleaseMap
+ case artistRelease of
+ Just { artist, release } -> do
+ let
+ sources =
+ [ { name: "lastfm", enabled: isJust cfg.lastfmApiKey, fetch: fetchLastfmGenre cfg.lastfmApiKey artist release }
+ , { name: "discogs", enabled: isJust cfg.discogsToken, fetch: fetchDiscogsGenre cfg.discogsToken artist release }
+ ]
+ finalGenre <- fetchFallbackGenre slug sources
+ upsertReleaseMetadata conn mbid finalGenre mbdata.label mbdata.year
+ case finalGenre of
+ Just genre ->
+ Log.info $ "Added fallback genre 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
+\ No newline at end of file
diff --git a/test/Main.purs b/test/Main.purs
@@ -15,7 +15,8 @@ import Types (Listen(..), ListenBrainzResponse(..), MbidMapping(..), Payload(..)
import Db (FilterField(..), connect, initDb, checkExists, upsertScrobble, getScrobbles, initReleaseMetadata, upsertReleaseMetadata, getStats, dbBaseName, getOldestTs, getUnenrichedMbids, getEmptyGenreMbids, getArtistReleasesByMbids, touchGenreCheckedAt)
import Data.Argonaut.Core (Json)
import Foreign.Object as Object
-import Main (sanitizeKey, listenBrainzUrl, lastfmTrackToListen, parseFilterField)
+import Main (listenBrainzUrl, lastfmTrackToListen, parseFilterField)
+import Cover (sanitizeKey)
import S3 (getS3Url)
main :: Effect Unit
