corpus

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

Cover.purs (9234B)

      1 module Cover
      2   ( CoverSource
      3   , sanitizeKey
      4   , fetchLastfmCoverUrl
      5   , fetchDiscogsCoverUrl
      6   , coverSources
      7   , serveCover
      8   ) where
      9 
     10 import Prelude
     11 
     12 import Control.Alt ((<|>))
     13 import Config (UserConfig, s3ConfigFromUser)
     14 import S3 (existsInS3, getPresignedUrl, uploadToS3)
     15 import Data.Array ((!!), find)
     16 import Data.Either (Either(..), fromRight')
     17 import Data.Foldable (foldM)
     18 import Data.Map as Map
     19 import Data.Maybe (Maybe(..), fromMaybe)
     20 import Data.String.CaseInsensitive (CaseInsensitiveString(..))
     21 import Data.String.Regex (regex, replace, parseFlags)
     22 import Partial.Unsafe (unsafeCrashWith)
     23 import Effect (Effect)
     24 import Effect.Aff (Aff, forkAff, try)
     25 import Effect.Class (liftEffect)
     26 import Effect.Exception as Exception
     27 import Fetch (fetch, Method(GET))
     28 import Fetch.Argonaut.Json (fromJson)
     29 import Foreign.Object as Object
     30 import Data.Argonaut.Core (toArray, toObject, toString, toBoolean)
     31 import Image (convertToAvif)
     32 import JSURI (encodeURIComponent)
     33 import Log as Log
     34 import Metrics as Metrics
     35 import Node.Buffer (fromArrayBuffer)
     36 import Node.HTTP.OutgoingMessage (setHeader, toWriteable)
     37 import Node.HTTP.ServerResponse (setStatusCode, toOutgoingMessage)
     38 import Node.HTTP.Types (ServerResponse)
     39 import Node.Stream (end)
     40 import Web.URL (URL)
     41 import Web.URL as URL
     42 import Web.URL.URLSearchParams as URLSearchParams
     43 
     44 type Response = ServerResponse
     45 
     46 type CoverSource =
     47   { name :: String
     48   , s3Key :: String
     49   , findUrl :: Aff (Maybe String)
     50   }
     51 
     52 sanitizeKey :: String -> String
     53 sanitizeKey = replace re1 "_" >>> replace re2 "_"
     54   where
     55   re1 = fromRight' (\_ -> unsafeCrashWith "invalid regex re1") $ regex "[^a-z0-9.-]" (parseFlags "gi")
     56   re2 = fromRight' (\_ -> unsafeCrashWith "invalid regex re2") $ regex "_{2,}" (parseFlags "g")
     57 
     58 getQueryParam :: String -> URL -> Maybe String
     59 getQueryParam key url = URLSearchParams.get key (URL.searchParams url)
     60 
     61 fetchCaaCoverUrl :: String -> Aff (Maybe String)
     62 fetchCaaCoverUrl mbid = do
     63   let url = "https://coverartarchive.org/release/" <> mbid
     64   let headers = { "User-Agent": "corpus/1.0 (+https://sr.ht/~mtmn/corpus)" }
     65   result <- try $ fetch url { method: GET, headers }
     66   case result of
     67     Right fr | fr.status == 200 -> do
     68       json <- fromJson fr.json
     69       pure $ do
     70         obj <- toObject json
     71         images <- Object.lookup "images" obj >>= toArray
     72         let
     73           isFront img = fromMaybe false $ toObject img >>= Object.lookup "front" >>= toBoolean
     74           isBack img = fromMaybe false $ toObject img >>= Object.lookup "back" >>= toBoolean
     75           getThumb key img = do
     76             thumbs <- toObject img >>= Object.lookup "thumbnails" >>= toObject
     77             Object.lookup key thumbs >>= toString
     78           pickFromImage img =
     79             getThumb "500" img <|> getThumb "large" img <|> getThumb "250" img <|> getThumb "small" img
     80         (find isFront images >>= pickFromImage)
     81           <|> (find isBack images >>= pickFromImage)
     82           <|> (images !! 0 >>= pickFromImage)
     83     _ ->
     84       pure Nothing
     85 
     86 fetchLastfmCoverUrl :: UserConfig -> String -> String -> Aff (Maybe String)
     87 fetchLastfmCoverUrl cfg artist release = case cfg.lastfmApiKey of
     88   Nothing ->
     89     pure Nothing
     90   Just k -> do
     91     let
     92       searchUrl = "https://ws.audioscrobbler.com/2.0/?method=album.getinfo&artist="
     93         <> (fromMaybe "" $ encodeURIComponent artist)
     94         <> "&album="
     95         <> (fromMaybe "" $ encodeURIComponent release)
     96         <> "&format=json&api_key="
     97         <> k
     98     Log.info $ "Searching Last.fm for: " <> artist <> " - " <> release
     99     let headers = { "User-Agent": "corpus/1.0 (+https://sr.ht/~mtmn/corpus)" }
    100     result <- try $ fetch searchUrl { method: GET, headers }
    101     case result of
    102       Right fr | fr.status == 200 -> do
    103         json <- fromJson fr.json
    104         pure $ do
    105           obj <- toObject json
    106           album <- Object.lookup "album" obj >>= toObject
    107           images <- Object.lookup "image" album >>= toArray
    108           imgObj <- images !! 2 >>= toObject
    109           u <- Object.lookup "#text" imgObj >>= toString
    110           if u == "" then Nothing else Just u
    111       _ ->
    112         pure Nothing
    113 
    114 fetchDiscogsCoverUrl :: UserConfig -> String -> String -> Aff (Maybe String)
    115 fetchDiscogsCoverUrl cfg artist release = case cfg.discogsToken of
    116   Nothing ->
    117     pure Nothing
    118   Just t -> do
    119     let
    120       queryStr = artist <> " " <> release
    121       searchUrl = "https://api.discogs.com/database/search?q="
    122         <> (fromMaybe "" $ encodeURIComponent queryStr)
    123         <> "&type=release&per_page=1"
    124     Log.info $ "Searching Discogs 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 fr | fr.status == 200 -> do
    128         json <- fromJson fr.json
    129         pure $ do
    130           obj <- toObject json
    131           results <- Object.lookup "results" obj >>= toArray
    132           firstResult <- results !! 0 >>= toObject
    133           Object.lookup "cover_image" firstResult >>= toString
    134       _ ->
    135         pure Nothing
    136 
    137 coverSources :: String -> String -> String -> UserConfig -> Array CoverSource
    138 coverSources mbid artist release cfg =
    139   let
    140     safeArtist = sanitizeKey artist
    141     safeRelease = sanitizeKey release
    142     caaSource =
    143       if mbid == "" then []
    144       else
    145         [ { name: "caa"
    146           , s3Key: "covers/caa/" <> sanitizeKey mbid <> ".avif"
    147           , findUrl: fetchCaaCoverUrl mbid
    148           }
    149         ]
    150   in
    151     caaSource <>
    152       [ { name: "discogs"
    153         , s3Key: "covers/discogs/" <> safeArtist <> "-" <> safeRelease <> ".avif"
    154         , findUrl:
    155             if artist == "" || release == "" then pure Nothing
    156             else fetchDiscogsCoverUrl cfg artist release
    157         }
    158       , { name: "lastfm"
    159         , s3Key: "covers/lastfm/" <> safeArtist <> "-" <> safeRelease <> ".avif"
    160         , findUrl:
    161             if artist == "" || release == "" then pure Nothing
    162             else fetchLastfmCoverUrl cfg artist release
    163         }
    164       ]
    165 
    166 serveCover :: (Response -> Effect Unit) -> UserConfig -> String -> URL -> Response -> Aff Unit
    167 serveCover serveNotFound cfg slug url res = do
    168   let
    169     mbid = fromMaybe "" (getQueryParam "mbid" url)
    170     artist = fromMaybe "" (getQueryParam "artist" url)
    171     release = fromMaybe "" (getQueryParam "release" url)
    172     s3cfg = s3ConfigFromUser cfg
    173 
    174   served <- foldM (trySource s3cfg) false (coverSources mbid artist release cfg)
    175   unless served $ liftEffect $ serveNotFound res
    176 
    177   where
    178   trySource _ true _ = pure true
    179   trySource s3cfg false { name, s3Key, findUrl } = do
    180     cached <- checkS3 s3cfg s3Key
    181     if cached then do
    182       Log.info $ "Serving " <> name <> " cover from cache: " <> s3Key
    183       liftEffect $ Metrics.incCoverRequest slug name "s3_hit"
    184       serveS3Redirect s3cfg s3Key res
    185       pure true
    186     else do
    187       mUrl <- findUrl
    188       case mUrl of
    189         Nothing ->
    190           pure false
    191         Just urlStr -> do
    192           redirectAndCache s3cfg urlStr s3Key res
    193           liftEffect $ Metrics.incCoverRequest slug name "fetch"
    194           pure true
    195 
    196   checkS3 s3cfg s3Key
    197     | not cfg.coverCacheEnabled = pure false
    198     | otherwise = do
    199         result <- try $ existsInS3 s3cfg s3Key
    200         pure $ case result of
    201           Right b -> b
    202           Left _ -> false
    203 
    204   serveS3Redirect s3cfg s3Key response = do
    205     presignedUrl <- getPresignedUrl s3cfg s3Key
    206     liftEffect $ do
    207       setStatusCode 302 response
    208       setHeader "Location" presignedUrl (toOutgoingMessage response)
    209       end (toWriteable (toOutgoingMessage response))
    210 
    211   -- Redirect the client immediately to the upstream URL, then fetch+convert+cache in background.
    212   -- This avoids blocking the response on AVIF conversion (which can take hundreds of ms).
    213   redirectAndCache s3cfg urlStr s3Key response = do
    214     liftEffect $ do
    215       setStatusCode 302 response
    216       setHeader "Location" urlStr (toOutgoingMessage response)
    217       setHeader "Cache-Control" "public, max-age=3600" (toOutgoingMessage response)
    218       end (toWriteable (toOutgoingMessage response))
    219     when cfg.coverCacheEnabled $ void $ forkAff do
    220       let headers = { "User-Agent": "corpus/1.0 (+https://sr.ht/~mtmn/corpus)" }
    221       fetchResult <- try $ fetch urlStr { method: GET, headers }
    222       case fetchResult of
    223         Right fr | fr.status == 200 -> do
    224           let
    225             contentType = Map.lookup (CaseInsensitiveString "content-type") fr.headers
    226             isAvif = case contentType of
    227               Just ct | ct == "image/avif" -> true
    228               _ -> false
    229           Log.info $ "Caching image: " <> urlStr
    230           ab <- fr.arrayBuffer
    231           avifAb <- if isAvif then pure ab else convertToAvif ab
    232           avifBuf <- liftEffect $ fromArrayBuffer avifAb
    233           uploadResult <- try $ uploadToS3 s3cfg s3Key avifBuf "image/avif"
    234           case uploadResult of
    235             Right _ -> Log.info $ "Uploaded " <> s3Key
    236             Left err -> Log.error $ "Failed to upload " <> s3Key <> ": " <> Exception.message err
    237         Right fr ->
    238           Log.warn $ "Background fetch failed for " <> urlStr <> " with status " <> show fr.status
    239         Left err ->
    240           Log.error $ "Background fetch error for " <> urlStr <> ": " <> Exception.message err