commit 8b8811d7e2c0cf6fe4e57880ef8d0b82470a7563
parent 82bbb061aa0d3d4e001b1727268660f91134d29d
Author: mtmn <miro@haravara.org>
Date: Wed, 22 Apr 2026 23:56:06 +0200
feat: try various cover art sizes
Diffstat:
4 files changed, 63 insertions(+), 28 deletions(-)
diff --git a/src/Cover.purs b/src/Cover.purs
@@ -31,11 +31,11 @@ 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)
-import Unsafe.Coerce (unsafeCoerce)
import Web.URL (URL)
import Web.URL as URL
import Web.URL.URLSearchParams as URLSearchParams
@@ -95,7 +95,7 @@ fetchDiscogsCoverUrl cfg artist release = case cfg.discogsToken of
<> (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 } }
+ 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
@@ -107,19 +107,23 @@ fetchDiscogsCoverUrl cfg artist release = case cfg.discogsToken of
_ ->
pure Nothing
-coverSources :: String -> String -> String -> UserConfig -> Array CoverSource
-coverSources mbid artist release cfg =
+coverSources :: String -> String -> String -> Maybe String -> UserConfig -> Array CoverSource
+coverSources mbid artist release mVariant cfg =
let
safeArtist = sanitizeKey artist
safeRelease = sanitizeKey release
+ variant = fromMaybe "front-500" mVariant
+ caaSource =
+ if mbid == "" then []
+ else
+ [ { name: "caa"
+ , s3Key: "covers/caa/" <> sanitizeKey mbid <> (if variant == "front-500" then "" else "-" <> variant) <> ".avif"
+ , findUrl: pure $ Just $ "https://coverartarchive.org/release/" <> mbid <> "/" <> variant
+ }
+ ]
in
- [ { name: "caa"
- , s3Key: "covers/caa/" <> sanitizeKey mbid <> ".avif"
- , findUrl:
- if mbid == "" then pure Nothing
- else pure $ Just $ "https://coverartarchive.org/release/" <> mbid <> "/front-500"
- }
- , { name: "lastfm"
+ caaSource <>
+ [ { name: "lastfm"
, s3Key: "covers/lastfm/" <> safeArtist <> "-" <> safeRelease <> ".avif"
, findUrl:
if artist == "" || release == "" then pure Nothing
@@ -139,9 +143,10 @@ serveCover serveNotFound cfg slug url res = do
mbid = fromMaybe "" (getQueryParam "mbid" url)
artist = fromMaybe "" (getQueryParam "artist" url)
release = fromMaybe "" (getQueryParam "release" url)
+ variant = getQueryParam "variant" url
s3cfg = s3ConfigFromUser cfg
- served <- foldM (trySource s3cfg) false (coverSources mbid artist release cfg)
+ served <- foldM (trySource s3cfg) false (coverSources mbid artist release variant cfg)
unless served $ liftEffect $ serveNotFound res
where
@@ -185,20 +190,24 @@ serveCover serveNotFound cfg slug url res = do
setHeader "Cache-Control" "public, max-age=3600" (toOutgoingMessage response)
end (toWriteable (toOutgoingMessage response))
when cfg.coverCacheEnabled $ void $ forkAff do
- fetchResult <- try $ fetch urlStr { method: GET }
+ let headers = { "User-Agent": "corpus/1.0 (+https://github.com/mtmn/corpus)" }
+ fetchResult <- try $ fetch urlStr { method: GET, headers }
case fetchResult of
Right fr | fr.status == 200 -> do
let
- isAvif = case Map.lookup (CaseInsensitiveString "content-type") fr.headers of
+ contentType = Map.lookup (CaseInsensitiveString "content-type") fr.headers
+ isAvif = case contentType 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
- uploadResult <- try $ uploadToS3 s3cfg s3Key (unsafeCoerce avifBuf) "image/avif"
+ Log.info $ "Caching image: " <> urlStr
+ ab <- fr.arrayBuffer
+ avifAb <- if isAvif then pure ab else convertToAvif ab
+ avifBuf <- liftEffect $ fromArrayBuffer avifAb
+ uploadResult <- try $ uploadToS3 s3cfg s3Key avifBuf "image/avif"
case uploadResult of
Right _ -> Log.info $ "Cached to S3: " <> s3Key
- Left err -> Log.error $ "S3 upload failed: " <> Exception.message err
- _ ->
- Log.warn $ "Background fetch failed for: " <> urlStr
-
+ Left err -> Log.error $ "S3 upload FAILED for " <> s3Key <> ": " <> Exception.message err
+ Right fr ->
+ Log.warn $ "Background fetch failed for " <> urlStr <> " with status " <> show fr.status
+ Left err ->
+ Log.error $ "Background fetch error for " <> urlStr <> ": " <> Exception.message err
diff --git a/src/State.elm b/src/State.elm
@@ -29,6 +29,7 @@ init flags url navKey =
, loading = True
, currentTime = Nothing
, failedCovers = Set.empty
+ , coverFallbacks = Dict.empty
, hoveredCover = Nothing
, expandedSections = Set.empty
, loadedSections = Set.empty
@@ -211,7 +212,22 @@ update msg model =
)
ImageError url ->
- ( { model | failedCovers = Set.insert url model.failedCovers }, Cmd.none )
+ 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 )
NextPage ->
let
diff --git a/src/Types.elm b/src/Types.elm
@@ -96,6 +96,7 @@ 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.hoveredCover model.similarStates idx listen ]
+ [ renderListen model.userSlug model.currentTime model.failedCovers model.coverFallbacks model.hoveredCover model.similarStates idx listen ]
, renderSimilarPanel model.similarStates key
]
)
@@ -169,8 +169,8 @@ renderContent model =
)
-renderListen : String -> Maybe Time.Posix -> Set String -> Maybe Int -> Dict String SimilarState -> Int -> Listen -> Html Msg
-renderListen userSlug currentTime failedCovers hoveredCover similarStates idx listen =
+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 =
let
artist =
Maybe.withDefault "" listen.artistName
@@ -192,7 +192,7 @@ renderListen userSlug currentTime failedCovers hoveredCover similarStates idx li
Nothing ->
listen.releaseMbid
- coverUrl =
+ baseCoverUrl =
"/cover?user="
++ userSlug
++ "&artist="
@@ -207,6 +207,15 @@ renderListen userSlug currentTime failedCovers hoveredCover similarStates idx li
""
)
+ variant =
+ case Dict.get baseCoverUrl coverFallbacks |> Maybe.withDefault 0 of
+ 1 -> "&variant=front-250"
+ 2 -> "&variant=back-500"
+ 3 -> "&variant=back-250"
+ _ -> ""
+
+ coverUrl = baseCoverUrl ++ variant
+
isZoomed =
hoveredCover == Just idx
@@ -235,7 +244,7 @@ renderListen userSlug currentTime failedCovers hoveredCover similarStates idx li
]
]
, div [ class "cover-wrapper" ]
- [ if Set.member coverUrl failedCovers then
+ [ if Set.member baseCoverUrl failedCovers then
text ""
else
