commit b59bc2ffe60e1fa8bd797209af5dd3ebcafd74f7
parent 0a06102a2d7d2f073e02b9be0945f7725f1076cb
Author: mtmn <miro@haravara.org>
Date: Thu, 23 Apr 2026 01:00:38 +0200
feat: lookup release json from caa before fetch
Diffstat:
4 files changed, 40 insertions(+), 52 deletions(-)
diff --git a/src/Cover.purs b/src/Cover.purs
@@ -9,9 +9,10 @@ module Cover
import Prelude
+import Control.Alt ((<|>))
import Config (UserConfig, s3ConfigFromUser)
import S3 (existsInS3, getS3Url, uploadToS3)
-import Data.Array ((!!))
+import Data.Array ((!!), find)
import Data.Either (Either(..))
import Data.Foldable (foldM)
import Data.Map as Map
@@ -26,7 +27,7 @@ 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 Data.Argonaut.Core (toArray, toObject, toString, toBoolean)
import Image (convertToAvif)
import JSURI (encodeURIComponent)
import Log as Log
@@ -57,6 +58,31 @@ sanitizeKey = replace re1 "_" >>> replace re2 "_"
getQueryParam :: String -> URL -> Maybe String
getQueryParam key url = URLSearchParams.get key (URL.searchParams url)
+fetchCaaCoverUrl :: String -> Aff (Maybe String)
+fetchCaaCoverUrl mbid = do
+ let url = "https://coverartarchive.org/release/" <> mbid
+ let headers = { "User-Agent": "corpus/1.0 (+https://github.com/mtmn/corpus)" }
+ result <- try $ fetch url { method: GET, headers }
+ case result of
+ Right fr | fr.status == 200 -> do
+ json <- fromJson fr.json
+ pure $ do
+ obj <- toObject json
+ images <- Object.lookup "images" obj >>= toArray
+ let
+ isFront img = fromMaybe false $ toObject img >>= Object.lookup "front" >>= toBoolean
+ isBack img = fromMaybe false $ toObject img >>= Object.lookup "back" >>= toBoolean
+ getThumb key img = do
+ thumbs <- toObject img >>= Object.lookup "thumbnails" >>= toObject
+ Object.lookup key thumbs >>= toString
+ pickFromImage img =
+ getThumb "500" img <|> getThumb "large" img <|> getThumb "250" img <|> getThumb "small" img
+ (find isFront images >>= pickFromImage)
+ <|> (find isBack images >>= pickFromImage)
+ <|> (images !! 0 >>= pickFromImage)
+ _ ->
+ pure Nothing
+
fetchLastfmCoverUrl :: UserConfig -> String -> String -> Aff (Maybe String)
fetchLastfmCoverUrl cfg artist release = case cfg.lastfmApiKey of
Nothing ->
@@ -108,17 +134,17 @@ fetchDiscogsCoverUrl cfg artist release = case cfg.discogsToken of
_ ->
pure Nothing
-coverSources :: String -> String -> String -> String -> UserConfig -> Array CoverSource
-coverSources mbid artist release variant cfg =
+coverSources :: String -> String -> String -> UserConfig -> Array CoverSource
+coverSources mbid artist release cfg =
let
safeArtist = sanitizeKey artist
safeRelease = sanitizeKey release
caaSource =
- if mbid == "" || variant == "" then []
+ if mbid == "" then []
else
[ { name: "caa"
- , s3Key: "covers/caa/" <> sanitizeKey mbid <> "-" <> variant <> ".avif"
- , findUrl: pure $ Just $ "https://coverartarchive.org/release/" <> mbid <> "/" <> variant
+ , s3Key: "covers/caa/" <> sanitizeKey mbid <> ".avif"
+ , findUrl: fetchCaaCoverUrl mbid
}
]
in
@@ -143,10 +169,9 @@ serveCover serveNotFound cfg slug url res = do
mbid = fromMaybe "" (getQueryParam "mbid" url)
artist = fromMaybe "" (getQueryParam "artist" url)
release = fromMaybe "" (getQueryParam "release" url)
- variant = fromMaybe "" (getQueryParam "variant" url)
s3cfg = s3ConfigFromUser cfg
- served <- foldM (trySource s3cfg) false (coverSources mbid artist release variant cfg)
+ served <- foldM (trySource s3cfg) false (coverSources mbid artist release cfg)
unless served $ liftEffect $ serveNotFound res
where
diff --git a/src/State.elm b/src/State.elm
@@ -29,7 +29,6 @@ init flags url navKey =
, loading = True
, currentTime = Nothing
, failedCovers = Set.empty
- , coverFallbacks = Dict.empty
, hoveredCover = Nothing
, expandedSections = Set.empty
, loadedSections = Set.empty
@@ -212,22 +211,7 @@ update msg model =
)
ImageError url ->
- let
- baseUrl =
- if String.contains "&variant=" url then
- String.split "&variant=" url |> List.head |> Maybe.withDefault url
-
- else
- url
-
- currentFallback =
- Dict.get baseUrl model.coverFallbacks |> Maybe.withDefault 0
- in
- if String.contains "&mbid=" baseUrl && currentFallback < 3 then
- ( { model | coverFallbacks = Dict.insert baseUrl (currentFallback + 1) model.coverFallbacks }, Cmd.none )
-
- else
- ( { model | failedCovers = Set.insert baseUrl model.failedCovers }, Cmd.none )
+ ( { model | failedCovers = Set.insert url model.failedCovers }, Cmd.none )
NextPage ->
let
diff --git a/src/Types.elm b/src/Types.elm
@@ -96,7 +96,6 @@ type alias Model =
, loading : Bool
, currentTime : Maybe Time.Posix
, failedCovers : Set String
- , coverFallbacks : Dict String Int
, hoveredCover : Maybe Int
, expandedSections : Set String
, loadedSections : Set String
diff --git a/src/View.elm b/src/View.elm
@@ -161,7 +161,7 @@ renderContent model =
in
div [ class "track-with-similar-container" ]
[ ul [ class "track-item" ]
- [ renderListen model.userSlug model.currentTime model.failedCovers model.coverFallbacks model.hoveredCover model.similarStates idx listen ]
+ [ renderListen model.userSlug model.currentTime model.failedCovers model.hoveredCover model.similarStates idx listen ]
, renderSimilarPanel model.similarStates key
]
)
@@ -169,8 +169,8 @@ renderContent model =
)
-renderListen : String -> Maybe Time.Posix -> Set String -> Dict String Int -> Maybe Int -> Dict String SimilarState -> Int -> Listen -> Html Msg
-renderListen userSlug currentTime failedCovers coverFallbacks hoveredCover similarStates idx listen =
+renderListen : String -> Maybe Time.Posix -> Set String -> Maybe Int -> Dict String SimilarState -> Int -> Listen -> Html Msg
+renderListen userSlug currentTime failedCovers hoveredCover similarStates idx listen =
let
artist =
Maybe.withDefault "" listen.artistName
@@ -192,7 +192,7 @@ renderListen userSlug currentTime failedCovers coverFallbacks hoveredCover simil
Nothing ->
listen.releaseMbid
- baseCoverUrl =
+ coverUrl =
"/cover?user="
++ userSlug
++ "&artist="
@@ -207,26 +207,6 @@ renderListen userSlug currentTime failedCovers coverFallbacks hoveredCover simil
""
)
- variant =
- case Dict.get baseCoverUrl coverFallbacks |> Maybe.withDefault 0 of
- 0 ->
- "front-500"
-
- 1 ->
- "front-250"
-
- 2 ->
- "back-500"
-
- 3 ->
- "back-250"
-
- _ ->
- ""
-
- coverUrl =
- baseCoverUrl ++ "&variant=" ++ variant
-
isZoomed =
hoveredCover == Just idx
@@ -255,7 +235,7 @@ renderListen userSlug currentTime failedCovers coverFallbacks hoveredCover simil
]
]
, div [ class "cover-wrapper" ]
- [ if Set.member baseCoverUrl failedCovers then
+ [ if Set.member coverUrl failedCovers then
text ""
else
