commit - a160446c6caa0bf12a69c4f70ee3e0f6e140f45c
commit + bfaf5c8ea21f19c303e9fb6101d9e75079d5be23
blob - 95ea29fe756d5940f7f1ea18de88856511585b6a
blob + 4ef9e0eaf4ca4eac5a3bca3a1ef07ea99bc8aa16
--- .tidyrc.json
+++ .tidyrc.json
{
- "importSort": "source",
- "importWrap": "source",
+ "importSort": "ide",
+ "importWrap": "auto",
"indent": 2,
"operatorsFile": null,
"ribbon": 1,
"typeArrowPlacement": "first",
"unicode": "source",
- "width": null
+ "width": 80
}
blob - e817ec0b9552d86467a65e7dfcb7e164740a0f2a
blob + 74dca74d8ae62458c8dbc4b997ee65e535632ac3
--- package.json
+++ package.json
{
- "name": "corpus",
- "version": "3.2.0",
- "description": "ListenBrainz and Last.fm frontend",
- "main": "index.js",
- "type": "module",
- "scripts": {
- "build": "spago build && esbuild output/Main/index.js --bundle --platform=node --format=esm --footer:js='main();' --outfile=server.js --external:http --external:https --external:dotenv --external:url --external:@duckdb/node-api --external:@aws-sdk/client-s3 --external:@aws-sdk/s3-request-presigner --external:prom-client --external:sharp --external:uuid --external:nodemailer && elm make src/Client.elm --output=client.js",
- "release": "spago build && purs-backend-es build && esbuild output-es/Main/index.js --bundle --platform=node --format=esm --footer:js='main();' --outfile=server.js --external:http --external:https --external:dotenv --external:url --external:@duckdb/node-api --external:@aws-sdk/client-s3 --external:@aws-sdk/s3-request-presigner --external:prom-client --external:sharp --external:uuid --external:nodemailer && elm make src/Client.elm --optimize --output=client.js && uglifyjs client.js --compress \"pure_funcs=[F2,F3,F4,F5,F6,F7,F8,F9,A2,A3,A4,A5,A6,A7,A8,A9],pure_getters,keep_fargs=false,unsafe_comps,unsafe\" | uglifyjs --mangle --output client.js",
- "test": "spago test",
- "tidy": "purs-tidy format-in-place src/**/*.purs"
- },
- "devDependencies": {
- "esbuild": "^0.28.1",
- "purescript-language-server": "^0.18.5",
- "purescript-psa": "^0.9.0",
- "purs-backend-es": "^1.4.3",
- "purs-tidy": "^0.11.1",
- "spago": "^1.0.4",
- "uglify-js": "^3.19.3",
- "whine": "^0.0.34"
- },
- "dependencies": {
- "@aws-sdk/client-s3": "^3.1101.0",
- "@aws-sdk/s3-request-presigner": "^3.1101.0",
- "@duckdb/node-api": "1.5.4-r.1",
- "dotenv": "^17.4.2",
- "nodemailer": "^6.10.1",
- "prom-client": "^15.1.3",
- "purescript": "^0.15.16",
- "sharp": "^0.35.3",
- "uuid": "^14.0.1"
- }
+ "name": "corpus",
+ "version": "3.2.0",
+ "description": "ListenBrainz and Last.fm frontend",
+ "main": "index.js",
+ "type": "module",
+ "scripts": {
+ "build": "spago build && esbuild output/Main/index.js --bundle --platform=node --format=esm --footer:js='main();' --outfile=server.js --external:http --external:https --external:dotenv --external:url --external:@duckdb/node-api --external:@aws-sdk/client-s3 --external:@aws-sdk/s3-request-presigner --external:prom-client --external:sharp --external:uuid --external:nodemailer && elm make src/Client.elm --output=client.js",
+ "release": "spago build && purs-backend-es build && esbuild output-es/Main/index.js --bundle --platform=node --format=esm --footer:js='main();' --outfile=server.js --external:http --external:https --external:dotenv --external:url --external:@duckdb/node-api --external:@aws-sdk/client-s3 --external:@aws-sdk/s3-request-presigner --external:prom-client --external:sharp --external:uuid --external:nodemailer && elm make src/Client.elm --optimize --output=client.js && uglifyjs client.js --compress \"pure_funcs=[F2,F3,F4,F5,F6,F7,F8,F9,A2,A3,A4,A5,A6,A7,A8,A9],pure_getters,keep_fargs=false,unsafe_comps,unsafe\" | uglifyjs --mangle --output client.js",
+ "test": "purs-tidy check src/**/*.purs test/**/*.purs && spago test",
+ "tidy": "purs-tidy format-in-place src/**/*.purs test/**/*.purs"
+ },
+ "devDependencies": {
+ "esbuild": "^0.28.1",
+ "purescript-language-server": "^0.18.5",
+ "purescript-psa": "^0.9.0",
+ "purs-backend-es": "^1.4.3",
+ "purs-tidy": "^0.11.1",
+ "spago": "^1.0.4",
+ "uglify-js": "^3.19.3",
+ "whine": "^0.0.34"
+ },
+ "dependencies": {
+ "@aws-sdk/client-s3": "^3.1101.0",
+ "@aws-sdk/s3-request-presigner": "^3.1101.0",
+ "@duckdb/node-api": "1.5.4-r.1",
+ "dotenv": "^17.4.2",
+ "nodemailer": "^6.10.1",
+ "prom-client": "^15.1.3",
+ "purescript": "^0.15.16",
+ "sharp": "^0.35.3",
+ "uuid": "^14.0.1"
+ }
}
blob - d0572ffb1513416708a1480733a1c306a990dd19
blob + 3f6d040b59ff2cfa9759f6819b8b45fbdbe92b49
--- src/Command.purs
+++ src/Command.purs
-module Command where
+module Command (run) where
import Prelude
import Control.Monad.Error.Class (throwError)
import Data.Argonaut (parseJson)
-import Data.Argonaut.Core (Json, fromArray, fromBoolean, fromNumber, fromObject, fromString, toArray, toObject, toString)
+import Data.Argonaut.Core
+ ( Json
+ , fromArray
+ , fromBoolean
+ , fromNumber
+ , fromObject
+ , fromString
+ , toArray
+ , toObject
+ , toString
+ )
import Data.Array (catMaybes, find, snoc)
import Data.Array as Array
import Data.Either (Either(..))
Just dir -> dir <> "/" <> file
encodeUserEntry
- :: { slug :: String, name :: Maybe String, dbFile :: String, lbUser :: Maybe String, lfUser :: Maybe String }
+ :: { slug :: String
+ , name :: Maybe String
+ , dbFile :: String
+ , lbUser :: Maybe String
+ , lfUser :: Maybe String
+ }
-> Json
encodeUserEntry e = fromObject $ Object.fromFoldable $ catMaybes
[ Just $ Tuple "slug" (fromString e.slug)
readUsersJson configFile = do
raw <- FSA.readTextFile UTF8 configFile
json <- case parseJson raw of
- Left e -> throwError (error $ "Failed to parse " <> configFile <> ": " <> show e)
+ Left e -> throwError
+ (error $ "Failed to parse " <> configFile <> ": " <> show e)
Right j -> pure j
case toObject json >>= Object.lookup "users" >>= toArray of
- Nothing -> throwError (error "Invalid users.json: expected { users: [...] }")
+ Nothing -> throwError
+ (error "Invalid users.json: expected { users: [...] }")
Just arr -> pure arr
writeUsersJson :: String -> Array Json -> Aff Unit
printUsage :: Aff Unit
printUsage = liftEffect do
log "Usage:"
- log " add-user --slug <slug> --db <file> [--name <name>] [--listenbrainz-user <user>] [--lastfm-user <user>]"
+ log
+ " add-user --slug <slug> --db <file> [--name <name>] [--listenbrainz-user <user>] [--lastfm-user <user>]"
log " reset-token --slug <slug>"
log " list-users"
exit' 1
+-- | Run the administrative command selected by the process arguments.
run :: String -> Array String -> Aff Unit
run configFile args = do
case Array.uncons args of
mName = getFlag "--name" args
mLbUser = getFlag "--listenbrainz-user" args
mLfUser = getFlag "--lastfm-user" args
- slug <- maybe (liftEffect $ log "Error: --slug is required" *> exit' 1) pure (getFlag "--slug" args)
- dbFile <- maybe (liftEffect $ log "Error: --db is required" *> exit' 1) pure (getFlag "--db" args)
+ slug <- maybe (liftEffect $ log "Error: --slug is required" *> exit' 1) pure
+ (getFlag "--slug" args)
+ dbFile <- maybe (liftEffect $ log "Error: --db is required" *> exit' 1) pure
+ (getFlag "--db" args)
users <- readUsersJson configFile
- when (isJust $ find (\u -> (toObject u >>= Object.lookup "slug" >>= toString) == Just slug) users)
+ when
+ ( isJust $ find
+ (\u -> (toObject u >>= Object.lookup "slug" >>= toString) == Just slug)
+ users
+ )
$ liftEffect
$ log ("Error: user '" <> slug <> "' already exists") *> exit' 1
- let newEntry = encodeUserEntry { slug, name: mName, dbFile, lbUser: mLbUser, lfUser: mLfUser }
+ let
+ newEntry = encodeUserEntry
+ { slug, name: mName, dbFile, lbUser: mLbUser, lfUser: mLfUser }
writeUsersJson configFile (snoc users newEntry)
conn <- Db.connect dbFile
Db.initDb conn
resetToken :: String -> Array String -> Aff Unit
resetToken configFile args = do
- slug <- maybe (liftEffect $ log "Error: --slug is required" *> exit' 1) pure (getFlag "--slug" args)
+ slug <- maybe (liftEffect $ log "Error: --slug is required" *> exit' 1) pure
+ (getFlag "--slug" args)
users <- readUsersJson configFile
- userJson <- maybe (liftEffect $ log ("Error: user '" <> slug <> "' not found") *> exit' 1) pure
- $ find (\u -> (toObject u >>= Object.lookup "slug" >>= toString) == Just slug) users
- dbFile <- maybe (throwError $ error $ "Cannot read databaseFile for user '" <> slug <> "'") pure
- $ toObject userJson >>= Object.lookup "config" >>= toObject >>= Object.lookup "databaseFile" >>= toString
+ userJson <-
+ maybe
+ (liftEffect $ log ("Error: user '" <> slug <> "' not found") *> exit' 1)
+ pure
+ $ find
+ ( \u -> (toObject u >>= Object.lookup "slug" >>= toString) == Just
+ slug
+ )
+ users
+ dbFile <-
+ maybe
+ ( throwError $ error $ "Cannot read databaseFile for user '" <> slug <>
+ "'"
+ )
+ pure
+ $ toObject userJson >>= Object.lookup "config" >>= toObject
+ >>= Object.lookup "databaseFile"
+ >>= toString
defaultDir <- liftEffect cwd
mDbPath <- liftEffect $ lookupEnv "DATABASE_PATH"
let fullPath = resolvePath defaultDir mDbPath dbFile
listUsers configFile = do
users <- readUsersJson configFile
liftEffect $ for_ users \u -> do
- let slug = fromMaybe "(root)" (toObject u >>= Object.lookup "slug" >>= toString)
+ let
+ slug = fromMaybe "(root)"
+ (toObject u >>= Object.lookup "slug" >>= toString)
let mName = toObject u >>= Object.lookup "name" >>= toString
log $ case mName of
Just name -> slug <> " (" <> name <> ")"
blob - ebb536d8b131834a75c6b15aee89863dd7290d33
blob + a530f1217640a39f20901ad4eb44e6969ce7d39f
--- src/Config.purs
+++ src/Config.purs
-module Config where
+module Config
+ ( AppConfig
+ , S3Config
+ , SmtpConfig
+ , UserConfig
+ , UserEntry
+ , defaultUserConfig
+ , fillUserConfigFromEnv
+ , loadConfig
+ , s3ConfigFromUser
+ ) where
import Prelude
-import Data.Argonaut.Core (Json)
-import Data.Function.Uncurried (Fn3, runFn3)
+import Control.Monad.Error.Class (throwError)
import Data.Argonaut (decodeJson, (.:), (.:?))
+import Data.Argonaut.Core (Json)
import Data.Either (Either(..))
+import Data.Function.Uncurried (Fn3, runFn3)
import Data.Int (fromString) as Data.Int
import Data.Maybe (Maybe(..), fromMaybe, isJust, isNothing)
import Data.String (joinWith)
import Data.Traversable (traverse)
import Effect (Effect)
-import Control.Monad.Error.Class (throwError)
import Effect.Aff (Aff, makeAff, nonCanceler)
import Effect.Class (liftEffect)
import Effect.Exception (error)
import Node.Process (cwd, lookupEnv)
+-- | Per-user runtime configuration after environment values are resolved.
type UserConfig =
{ listenbrainzUser :: Maybe String
, lastfmUser :: Maybe String
, backupIntervalHours :: Int
}
+-- | A configured user and their URL slug.
type UserEntry =
{ slug :: String
, name :: Maybe String
, config :: UserConfig
}
+-- | Process-wide configuration and configured users.
type AppConfig =
{ port :: Int
, host :: String
, users :: Array UserEntry
}
--- SMTP settings for notification email (SMTP_* env vars).
+-- | SMTP settings for notification email.
type SmtpConfig =
{ host :: Maybe String
, port :: Int
, from :: Maybe String
}
+-- | S3-compatible object storage settings.
type S3Config =
{ bucket :: Maybe String
, region :: String
, addressingStyle :: Maybe String
}
+-- | Extract object-storage settings from a user configuration.
s3ConfigFromUser :: UserConfig -> S3Config
s3ConfigFromUser cfg =
{ bucket: cfg.s3Bucket
}
-- Defaults for a self-registered user; creds and DB path are filled by fillUserConfigFromEnv.
+-- | Create defaults for a newly self-registered user.
defaultUserConfig :: String -> Maybe String -> Maybe String -> UserConfig
defaultUserConfig databaseFile listenbrainzUser lastfmUser =
{ listenbrainzUser
foreign import loadConfigImpl
:: Fn3 String (String -> Effect Unit) (Json -> Effect Unit) (Effect Unit)
+-- | Load, resolve, and validate application configuration.
loadConfig :: String -> Aff AppConfig
loadConfig path = do
json <- makeAff \cb ->
metricsEnabled = metricsEnabledStr == Just "true"
corsOrigin = fromMaybe "*" corsOriginStr
registrationEnabled = registrationEnabledStr == Just "true"
- registrationsDb = resolvePath (fromMaybe "registrations.db" registrationsDbEnv)
+ registrationsDb = resolvePath
+ (fromMaybe "registrations.db" registrationsDbEnv)
smtp =
{ host: smtpHost
, port: fromMaybe 587 (smtpPortStr >>= Data.Int.fromString)
Right cfg -> pure cfg
-- Fills shared credentials and resolves the database path from the environment.
+-- | Fill shared credentials and resolve the database path from the environment.
fillUserConfigFromEnv :: UserConfig -> Aff UserConfig
fillUserConfigFromEnv cfg = do
lastfmApiKey <- liftEffect $ lookupEnv "LASTFM_API_KEY"
c = entry.config
label = if entry.slug == "" then "root" else entry.slug
lfmMissing =
- if isJust c.lastfmUser && isNothing c.lastfmApiKey then [ "LASTFM_API_KEY" ]
+ if isJust c.lastfmUser && isNothing c.lastfmApiKey then
+ [ "LASTFM_API_KEY" ]
else []
s3Missing =
if c.coverCacheEnabled || c.backupEnabled then
(if isNothing c.s3Bucket then [ "S3_BUCKET" ] else [])
- <> (if isNothing c.awsAccessKeyId then [ "AWS_ACCESS_KEY_ID" ] else [])
- <> (if isNothing c.awsSecretAccessKey then [ "AWS_SECRET_ACCESS_KEY" ] else [])
+ <>
+ (if isNothing c.awsAccessKeyId then [ "AWS_ACCESS_KEY_ID" ] else [])
+ <>
+ ( if isNothing c.awsSecretAccessKey then [ "AWS_SECRET_ACCESS_KEY" ]
+ else []
+ )
<> (if isNothing c.awsEndpointUrl then [ "AWS_ENDPOINT_URL" ] else [])
else []
missing = lfmMissing <> s3Missing
in
if missing == [] then Right entry
- else Left ("User '" <> label <> "': missing required env vars: " <> joinWith ", " missing)
+ else Left
+ ( "User '" <> label <> "': missing required env vars: " <> joinWith ", "
+ missing
+ )
mapLeft :: forall a b c. (a -> c) -> Either a b -> Either c b
mapLeft f (Left a) = Left (f a)
blob - 6d2e424a29701f96420eb7c4aaaad1ccac9f904a
blob + 18660f21548fbb098e07f59021ebca25a905edd0
--- src/Cosine.purs
+++ src/Cosine.purs
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.Array ((!!))
+import Data.Either (Either(..), hush)
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 Fetch (Method(GET), fetch)
import Foreign.Object as Object
-import JSURI (encodeURIComponent)
import Http (apiTimeout, withTimeout)
+import JSURI (encodeURIComponent)
import Log as Log
import Metrics as Metrics
import Node.Encoding (Encoding(UTF8))
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
+import Web.URL.URLSearchParams as URLSearchParams
type Response = ServerResponse
getQueryParam :: String -> URL -> Maybe String
getQueryParam key url = URLSearchParams.get key (URL.searchParams url)
+-- | Fetch similar tracks from Cosine Club or return an empty result when disabled.
fetchCosineSimilar :: String -> UserConfig -> String -> Aff String
fetchCosineSimilar slug cfg query = do
let apiKey = fromMaybe "" cfg.cosineApiKey
liftEffect $ Metrics.incCosineRequest slug "not_configured"
pure "{\"data\":{\"similar_tracks\":[]},\"success\":true}"
else do
- let headers = { "User-Agent": "corpus/1.0 +https://sr.ht/~mtmn/corpus", "Authorization": "Bearer " <> apiKey }
- let searchUrl = "https://cosine.club/api/v1/search?q=" <> (fromMaybe "" $ encodeURIComponent query) <> "&limit=1"
+ let
+ headers =
+ { "User-Agent": "corpus/1.0 +https://sr.ht/~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 $ withTimeout apiTimeout "Cosine Club search" $ fetch searchUrl { method: GET, headers: headers }
+ searchResult <- try $ withTimeout apiTimeout "Cosine Club search" $ fetch
+ searchUrl
+ { method: GET, headers: headers }
case searchResult of
Left err -> do
liftEffect $ Metrics.incCosineRequest slug "error"
liftEffect $ Metrics.incCosineRequest slug "error"
throwError (Exception.error "Search API error")
else do
- searchBody <- withTimeout apiTimeout "Cosine Club search response" searchRes.text
+ searchBody <- withTimeout apiTimeout "Cosine Club search response"
+ searchRes.text
let
mTrackId = do
json <- hush $ parseJson searchBody
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"
+ let
+ similarUrl = "https://cosine.club/api/v1/tracks/" <> trackId <>
+ "/similar?limit=10"
Log.info $ "Cosine Club: fetching similar for ID " <> trackId
- similarResult <- try $ withTimeout apiTimeout "Cosine Club similar lookup" $ fetch similarUrl { method: GET, headers: headers }
+ similarResult <- try
+ $ withTimeout apiTimeout "Cosine Club similar lookup"
+ $ fetch similarUrl { method: GET, headers: headers }
case similarResult of
Left err -> do
liftEffect $ Metrics.incCosineRequest slug "error"
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
+ 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"
- withTimeout apiTimeout "Cosine Club similar response" similarRes.text
+ withTimeout apiTimeout "Cosine Club similar response"
+ similarRes.text
+-- | Serve the similar-track JSON endpoint.
serveSimilar
:: (Response -> String -> Effect Unit)
-> (Response -> Int -> String -> String -> Effect Unit)
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"
+ 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"
+ liftEffect $ serveError res 502 "Bad Gateway"
+ "Failed to fetch similar tracks"
Right responseBody ->
liftEffect $ do
setStatusCode 200 res
blob - ce457b60afff7dd07f43ed8a04ea99c11c599986
blob + 634a7a09d990a6cac56ab53372670f8b32dbc858
--- src/Cover.purs
+++ src/Cover.purs
import Prelude
-import Control.Alt ((<|>))
import Config (UserConfig, s3ConfigFromUser)
-import S3 (existsInS3, getPresignedUrl, uploadToS3)
-import Data.Array ((!!), find)
+import Control.Alt ((<|>))
+import Data.Argonaut.Core (toArray, toBoolean, toObject, toString)
+import Data.Array (find, (!!))
import Data.Either (Either(..), hush)
import Data.Foldable (foldM, for_)
import Data.Map as Map
import Data.Maybe (Maybe(..), fromMaybe, isJust)
import Data.String.CaseInsensitive (CaseInsensitiveString(..))
-import Data.String.Regex (Regex, regex, replace, parseFlags)
+import Data.String.Regex (Regex, parseFlags, regex, replace)
import Effect (Effect)
import Effect.Aff (Aff, forkAff, try)
import Effect.Class (liftEffect)
import Effect.Exception as Exception
-import Fetch (fetch, Method(GET))
+import Fetch (Method(GET), fetch)
import Fetch.Argonaut.Json (fromJson)
import Foreign.Object as Object
-import Data.Argonaut.Core (toArray, toObject, toString, toBoolean)
-import Image (arrayBufferByteLength, convertToAvif)
import Http (apiTimeout, imageTimeout, withTimeout)
+import Image (arrayBufferByteLength, convertToAvif)
import JSURI (encodeURIComponent)
import Log as Log
import Metrics as Metrics
import Node.HTTP.ServerResponse (setStatusCode, toOutgoingMessage)
import Node.HTTP.Types (ServerResponse)
import Node.Stream (end)
+import S3 (existsInS3, getPresignedUrl, uploadToS3)
import Web.URL (URL)
import Web.URL as URL
import Web.URL.URLSearchParams as URLSearchParams
foreign import tryStartCacheFillImpl :: String -> Effect Boolean
foreign import finishCacheFillImpl :: String -> Effect Unit
+-- | Claim a cache-fill job when it is not already running or capacity is free.
tryStartCacheFill :: String -> Effect Boolean
tryStartCacheFill = tryStartCacheFillImpl
+-- | Release a previously claimed cache-fill job.
finishCacheFill :: String -> Effect Unit
finishCacheFill = finishCacheFillImpl
type Response = ServerResponse
+-- | A lookup source and cache key for one candidate cover image.
type CoverSource =
{ name :: String
, s3Key :: String
, findUrl :: Aff (Maybe String)
}
+-- | Normalize a source value for use in an S3 key.
sanitizeKey :: String -> String
sanitizeKey = safeReplace sanitizeKeyRe1 "_" >>> safeReplace sanitizeKeyRe2 "_"
sanitizeKeyRe2 :: Maybe Regex
sanitizeKeyRe2 = hush $ regex "_{2,}" (parseFlags "g")
+-- | Build a process-local key for one bucket/object cache-fill job.
cacheJobKey :: String -> String -> String
cacheJobKey bucket s3Key = bucket <> ":" <> s3Key
fetchCaaCoverUrl mbid = do
let url = "https://coverartarchive.org/release/" <> mbid
let headers = { "User-Agent": "corpus/1.0 (+https://sr.ht/~mtmn/corpus)" }
- result <- try $ withTimeout apiTimeout "Cover Art Archive lookup" $ fetch url { method: GET, headers }
+ result <- try $ withTimeout apiTimeout "Cover Art Archive lookup" $ fetch url
+ { method: GET, headers }
case result of
Right fr | fr.status == 200 -> do
json <- fromJson fr.json
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
+ 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
+ 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
+-- | Find a Last.fm album cover URL when the service is configured.
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
+ 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
let headers = { "User-Agent": "corpus/1.0 (+https://sr.ht/~mtmn/corpus)" }
- result <- try $ withTimeout apiTimeout "Last.fm cover lookup" $ fetch searchUrl { method: GET, headers }
+ result <- try $ withTimeout apiTimeout "Last.fm cover lookup" $ fetch
+ searchUrl
+ { method: GET, headers }
case result of
Right fr | fr.status == 200 -> do
json <- fromJson fr.json
_ ->
pure Nothing
+-- | Find a Discogs release cover URL when the service is configured.
fetchDiscogsCoverUrl :: UserConfig -> String -> String -> Aff (Maybe String)
fetchDiscogsCoverUrl cfg artist release = case cfg.discogsToken of
Nothing ->
<> (fromMaybe "" $ encodeURIComponent queryStr)
<> "&type=release&per_page=1"
Log.info $ "Searching Discogs for: " <> queryStr
- result <- try $ withTimeout apiTimeout "Discogs cover lookup" $ fetch searchUrl { method: GET, headers: { "User-Agent": "corpus/1.0 (+https://sr.ht/~mtmn/corpus)", "Authorization": "Discogs token=" <> t } }
+ result <- try $ withTimeout apiTimeout "Discogs cover lookup" $ fetch
+ searchUrl
+ { method: GET
+ , headers:
+ { "User-Agent": "corpus/1.0 (+https://sr.ht/~mtmn/corpus)"
+ , "Authorization": "Discogs token=" <> t
+ }
+ }
case result of
Right fr | fr.status == 200 -> do
json <- fromJson fr.json
_ ->
pure Nothing
+-- | List cover sources in cache and fallback order for a release.
coverSources :: String -> String -> String -> UserConfig -> Array CoverSource
coverSources mbid artist release cfg =
let
in
caaSource <>
[ { name: "discogs"
- , s3Key: "covers/discogs/" <> safeArtist <> "-" <> safeRelease <> ".avif"
+ , 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
+-- | Serve a cached cover or redirect to an upstream source and populate S3.
+serveCover
+ :: (Response -> Effect Unit)
+ -> UserConfig
+ -> String
+ -> URL
+ -> Response
+ -> Aff Unit
serveCover serveNotFound cfg slug url res = do
let
mbid = fromMaybe "" (getQueryParam "mbid" url)
s3cfg = s3ConfigFromUser cfg
cacheEnabled = cfg.coverCacheEnabled && isJust s3cfg.bucket
- served <- foldM (trySource s3cfg cacheEnabled) false (coverSources mbid artist release cfg)
+ served <- foldM (trySource s3cfg cacheEnabled) false
+ (coverSources mbid artist release cfg)
unless served $ liftEffect $ serveNotFound res
where
serveRedirect presignedUrl Nothing res
pure true
Left err -> do
- Log.warn $ "Failed to sign cached cover " <> s3Key <> ": " <> Exception.message err
+ Log.warn $ "Failed to sign cached cover " <> s3Key <> ": " <>
+ Exception.message err
tryUpstream false
else do
tryUpstream canCache
found <- try findUrl
case found of
Left err -> do
- Log.warn $ "Cover lookup failed for " <> name <> ": " <> Exception.message err
+ Log.warn $ "Cover lookup failed for " <> name <> ": " <>
+ Exception.message err
pure false
Right Nothing ->
pure false
started <- liftEffect $ tryStartCacheFill jobKey
when started $ void $ forkAff do
_ <- try do
- let headers = { "User-Agent": "corpus/1.0 (+https://sr.ht/~mtmn/corpus)" }
- fetchResult <- try $ withTimeout imageTimeout "Cover image request" $ fetch urlStr { method: GET, headers }
+ let
+ headers = { "User-Agent": "corpus/1.0 (+https://sr.ht/~mtmn/corpus)" }
+ fetchResult <- try $ withTimeout imageTimeout "Cover image request" $
+ fetch urlStr { method: GET, headers }
case fetchResult of
Right fr | fr.status == 200 -> do
let
- contentType = Map.lookup (CaseInsensitiveString "content-type") fr.headers
+ contentType = Map.lookup (CaseInsensitiveString "content-type")
+ fr.headers
isAvif = case contentType of
Just ct | ct == "image/avif" -> true
_ -> false
Log.info $ "Caching image: " <> urlStr
- bodyResult <- try $ withTimeout imageTimeout "Cover image download" fr.arrayBuffer
+ bodyResult <- try $ withTimeout imageTimeout "Cover image download"
+ fr.arrayBuffer
case bodyResult of
- Left err -> Log.error $ "Cover image download failed for " <> urlStr <> ": " <> Exception.message err
+ Left err -> Log.error $ "Cover image download failed for "
+ <> urlStr
+ <> ": "
+ <> Exception.message err
Right ab -> do
bytes <- liftEffect $ arrayBufferByteLength ab
if bytes > maxCoverBytes then
- Log.warn $ "Skipping oversized cover (" <> show bytes <> " bytes): " <> urlStr
+ Log.warn $ "Skipping oversized cover (" <> show bytes
+ <> " bytes): "
+ <> urlStr
else do
avifAb <- if isAvif then pure ab else convertToAvif ab
avifBuf <- liftEffect $ fromArrayBuffer avifAb
- uploadResult <- try $ uploadToS3 s3cfg s3Key avifBuf "image/avif"
+ uploadResult <- try $ uploadToS3 s3cfg s3Key avifBuf
+ "image/avif"
case uploadResult of
Right _ -> Log.info $ "Uploaded " <> s3Key
- Left err -> Log.error $ "Failed to upload " <> s3Key <> ": " <> Exception.message err
+ Left err -> Log.error $ "Failed to upload " <> s3Key <> ": "
+ <> Exception.message err
Right fr ->
- Log.warn $ "Background fetch failed for " <> urlStr <> " with status " <> show fr.status
+ Log.warn $ "Background fetch failed for " <> urlStr
+ <> " with status "
+ <> show fr.status
Left err ->
- Log.error $ "Background fetch error for " <> urlStr <> ": " <> Exception.message err
+ Log.error $ "Background fetch error for " <> urlStr <> ": " <>
+ Exception.message err
liftEffect $ finishCacheFill jobKey
blob - cb5b1a7a16523d40728f8adb9882786860f770fa
blob + 8d0c5a6f93e8bb20f9677a11c4f7caca422e86bc
--- src/Db.purs
+++ src/Db.purs
-module Db where
+module Db
+ ( Connection
+ , FilterField(..)
+ , backupDb
+ , checkExists
+ , closeConnection
+ , connect
+ , dbBaseName
+ , fromString
+ , getArtistReleasesByMbids
+ , getEmptyGenreMbids
+ , getOldestTs
+ , getOrCreateToken
+ , getScrobbles
+ , getStats
+ , getTokenUser
+ , getUnenrichedMbids
+ , initDb
+ , initReleaseMetadata
+ , ping
+ , queryAll
+ , run
+ , toParam
+ , touchGenreCheckedAt
+ , upsertReleaseMetadata
+ , upsertScrobble
+ , withTransaction
+ ) where
import Prelude
import Config (S3Config)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Rec.Class (forever)
-import Data.Argonaut.Core (Json, toObject, toNumber, toString)
-import Data.Array (mapMaybe, (!!), last, length, null, replicate)
+import Data.Argonaut.Core (Json, toNumber, toObject, toString)
+import Data.Array (last, length, mapMaybe, null, replicate, (!!))
import Data.Either (Either(..))
import Data.Foldable (for_)
import Data.Formatter.DateTime (formatDateTime)
import Data.Function.Uncurried (Fn2, Fn4, runFn2, runFn4)
+import Data.Generic.Rep (class Generic)
import Data.Int as Int
import Data.Maybe (Maybe(..), fromMaybe)
-import Data.Generic.Rep (class Generic)
-import Data.Show.Generic (genericShow)
import Data.Nullable (Nullable, toMaybe, toNullable)
+import Data.Show.Generic (genericShow)
import Data.String (Pattern(..), split, stripSuffix)
import Data.String.Common (joinWith)
import Data.Time.Duration (Milliseconds(..))
import Metrics as Metrics
import Node.FS.Aff as FSA
import S3 as S3
-import Types (Listen(..), TrackMetadata(..), MbidMapping(..), Stats(..), StatsEntry(..))
+import Types
+ ( Listen(..)
+ , MbidMapping(..)
+ , Stats(..)
+ , StatsEntry(..)
+ , TrackMetadata(..)
+ )
import Unsafe.Coerce (unsafeCoerce)
+-- | An open SQLite database connection.
foreign import data Connection :: Type
-- | Coerces a value to Foreign for SQL parameters.
toParam :: forall a. a -> Foreign
toParam = unsafeCoerce
-data FilterField = FilterArtist | FilterAlbum | FilterLabel | FilterYear | FilterGenre | FilterTrack
+-- | Fields that can be used to filter a scrobble query.
+data FilterField
+ = FilterArtist
+ | FilterAlbum
+ | FilterLabel
+ | FilterYear
+ | FilterGenre
+ | FilterTrack
derive instance Eq FilterField
derive instance Generic FilterField _
instance Show FilterField where
show = genericShow
+-- | Parse an API filter-field name.
fromString :: String -> Maybe FilterField
fromString "artist" = Just FilterArtist
fromString "album" = Just FilterAlbum
fromString "track" = Just FilterTrack
fromString _ = Nothing
-foreign import connectImpl :: Fn2 String (Nullable Error -> Nullable Connection -> Effect Unit) (Effect Unit)
-foreign import runImpl :: Fn4 Connection String (Array Foreign) (Nullable Error -> Effect Unit) (Effect Unit)
-foreign import allImpl :: Fn4 Connection String (Array Foreign) (Nullable Error -> Nullable (Array Json) -> Effect Unit) (Effect Unit)
-foreign import checkpointImpl :: Fn2 Connection (Nullable Error -> Effect Unit) (Effect Unit)
-foreign import closeConnectionImpl :: Fn2 Connection (Nullable Error -> Effect Unit) (Effect Unit)
+foreign import connectImpl
+ :: Fn2 String (Nullable Error -> Nullable Connection -> Effect Unit)
+ (Effect Unit)
+
+foreign import runImpl
+ :: Fn4 Connection String (Array Foreign) (Nullable Error -> Effect Unit)
+ (Effect Unit)
+
+foreign import allImpl
+ :: Fn4 Connection String (Array Foreign)
+ (Nullable Error -> Nullable (Array Json) -> Effect Unit)
+ (Effect Unit)
+
+foreign import checkpointImpl
+ :: Fn2 Connection (Nullable Error -> Effect Unit) (Effect Unit)
+
+foreign import closeConnectionImpl
+ :: Fn2 Connection (Nullable Error -> Effect Unit) (Effect Unit)
+
foreign import sha256 :: String -> String
+-- | Open a SQLite database at the supplied path.
connect :: String -> Aff Connection
connect path = makeAff \cb -> do
runFn2 connectImpl path \err conn ->
Nothing -> cb (Left $ error "Failed to create connection")
pure nonCanceler
+-- | Execute a parameterized SQL statement.
run :: Connection -> String -> Array Foreign -> Aff Unit
run conn sql params = makeAff \cb -> do
runFn4 runImpl conn sql params \err ->
-- Closes the underlying DuckDB connection, releasing its file lock so the
-- database file can be deleted.
+-- | Close an open database connection.
closeConnection :: Connection -> Aff Unit
closeConnection conn = makeAff \cb -> do
runFn2 closeConnectionImpl conn \err ->
Nothing -> cb (Right unit)
pure nonCanceler
+-- | Derive the backup-safe database filename from a path.
dbBaseName :: String -> String
dbBaseName path =
let
liftEffect $ Metrics.setDbBackupLastSuccess slug
liftEffect $ Metrics.incDbBackupRun slug "success"
+-- | Upload a database backup when the configured interval has elapsed.
backupDb :: Connection -> String -> S3Config -> Number -> String -> Aff Unit
backupDb conn dbFile s3cfg intervalMs slug = forever do
delay (Milliseconds intervalMs)
-- Acquires the write lock, runs the action inside a transaction, then releases.
-- Uses bracket to guarantee lock release even on fiber kill, preventing deadlocks.
+-- | Run an action in a serialized SQLite transaction.
withTransaction :: forall a. Connection -> AVar Unit -> Aff a -> Aff a
withTransaction conn lock action =
bracket (Avar.take lock) (\_ -> Avar.put unit lock) \_ -> do
void $ try $ run conn "COMMIT" []
pure v
+-- | Return all rows from a parameterized SQL query.
queryAll :: Connection -> String -> Array Foreign -> Aff (Array Json)
queryAll conn sql params = makeAff \cb -> do
runFn4 allImpl conn sql params \err rows ->
Nothing -> cb (Right (fromMaybe [] (toMaybe rows)))
pure nonCanceler
+-- | Create the core scrobble schema when it is absent.
initDb :: Connection -> Aff Unit
initDb conn = do
- run conn "CREATE TABLE IF NOT EXISTS scrobbles (listened_at BIGINT PRIMARY KEY, track_name VARCHAR, artist_name VARCHAR, release_name VARCHAR, release_mbid VARCHAR, caa_release_mbid VARCHAR)" []
- run conn "CREATE TABLE IF NOT EXISTS api_tokens (slug VARCHAR PRIMARY KEY, hashed_token VARCHAR UNIQUE)" []
+ run conn
+ "CREATE TABLE IF NOT EXISTS scrobbles (listened_at BIGINT PRIMARY KEY, track_name VARCHAR, artist_name VARCHAR, release_name VARCHAR, release_mbid VARCHAR, caa_release_mbid VARCHAR)"
+ []
+ run conn
+ "CREATE TABLE IF NOT EXISTS api_tokens (slug VARCHAR PRIMARY KEY, hashed_token VARCHAR UNIQUE)"
+ []
+-- | Look up or create the API token for a user slug.
getOrCreateToken :: Connection -> String -> Aff (Maybe String)
getOrCreateToken conn slug = do
- rows <- queryAll conn "SELECT hashed_token FROM api_tokens WHERE slug = ?" [ toParam slug ]
+ rows <- queryAll conn "SELECT hashed_token FROM api_tokens WHERE slug = ?"
+ [ toParam slug ]
case rows !! 0 >>= toObject >>= Object.lookup "hashed_token" >>= toString of
Just _ ->
pure Nothing
Nothing -> do
token <- liftEffect $ map UUID.toString UUID.genUUID
let hashedToken = sha256 token
- run conn "INSERT INTO api_tokens (slug, hashed_token) VALUES (?, ?)" [ toParam slug, toParam hashedToken ]
+ run conn "INSERT INTO api_tokens (slug, hashed_token) VALUES (?, ?)"
+ [ toParam slug, toParam hashedToken ]
pure $ Just token
+-- | Test whether a scrobble timestamp already exists.
checkExists :: Connection -> Int -> Aff Boolean
checkExists conn ts = do
- rows <- queryAll conn "SELECT 1 FROM scrobbles WHERE listened_at = ?" [ toParam ts ]
+ rows <- queryAll conn "SELECT 1 FROM scrobbles WHERE listened_at = ?"
+ [ toParam ts ]
pure case rows of
[] -> false
_ -> true
+-- | Get the oldest stored scrobble timestamp.
getOldestTs :: Connection -> Aff (Maybe Int)
getOldestTs conn = do
rows <- queryAll conn "SELECT MIN(listened_at) as min_ts FROM scrobbles" []
let ts = Int.round n
if ts == 0 then Nothing else Just ts
+-- | Insert or update one normalized listen.
upsertScrobble :: Connection -> Listen -> Aff Unit
upsertScrobble conn (Listen { listenedAt, trackMetadata: TrackMetadata track }) =
for_ listenedAt \ts -> do
let
- mbid = fromMaybe (MbidMapping { releaseMbid: Nothing, caaReleaseMbid: Nothing }) track.mbidMapping
+ mbid = fromMaybe
+ (MbidMapping { releaseMbid: Nothing, caaReleaseMbid: Nothing })
+ track.mbidMapping
MbidMapping m = mbid
params =
[ toParam ts
, toParam (fromMaybe "" m.releaseMbid)
, toParam (fromMaybe "" m.caaReleaseMbid)
]
- run conn "INSERT INTO scrobbles SELECT * FROM (SELECT ? as listened_at, ? as track_name, ? as artist_name, ? as release_name, ? as release_mbid, ? as caa_release_mbid) t WHERE NOT EXISTS (SELECT 1 FROM scrobbles WHERE listened_at = t.listened_at)" params
+ run conn
+ "INSERT INTO scrobbles SELECT * FROM (SELECT ? as listened_at, ? as track_name, ? as artist_name, ? as release_name, ? as release_mbid, ? as caa_release_mbid) t WHERE NOT EXISTS (SELECT 1 FROM scrobbles WHERE listened_at = t.listened_at)"
+ params
scrobbleCols :: String
-scrobbleCols = "SELECT s.listened_at, s.track_name, s.artist_name, s.release_name, s.release_mbid, s.caa_release_mbid, rm.genre, rm.label"
+scrobbleCols =
+ "SELECT s.listened_at, s.track_name, s.artist_name, s.release_name, s.release_mbid, s.caa_release_mbid, rm.genre, rm.label"
scrobbleFromLeft :: String
-scrobbleFromLeft = " FROM scrobbles s LEFT JOIN release_metadata rm ON s.release_mbid = rm.release_mbid"
+scrobbleFromLeft =
+ " FROM scrobbles s LEFT JOIN release_metadata rm ON s.release_mbid = rm.release_mbid"
scrobbleFromInner :: String
-scrobbleFromInner = " FROM scrobbles s JOIN release_metadata rm ON s.release_mbid = rm.release_mbid"
+scrobbleFromInner =
+ " FROM scrobbles s JOIN release_metadata rm ON s.release_mbid = rm.release_mbid"
scrobbleOrderPage :: String
scrobbleOrderPage = " ORDER BY s.listened_at DESC LIMIT ? OFFSET ?"
-getScrobbles :: Connection -> Int -> Int -> Maybe { field :: FilterField, value :: String } -> Maybe String -> Aff (Array Listen)
+-- | Query a page of stored scrobbles with optional filtering.
+getScrobbles
+ :: Connection
+ -> Int
+ -> Int
+ -> Maybe { field :: FilterField, value :: String }
+ -> Maybe String
+ -> Aff (Array Listen)
getScrobbles conn limit offset _ (Just q) = do
let pattern = "%" <> q <> "%"
rows <- queryAll conn
( scrobbleCols <> scrobbleFromLeft
- <> " WHERE (s.track_name ILIKE ? OR s.artist_name ILIKE ? OR s.release_name ILIKE ? OR rm.label ILIKE ?)"
+ <>
+ " WHERE (s.track_name ILIKE ? OR s.artist_name ILIKE ? OR s.release_name ILIKE ? OR rm.label ILIKE ?)"
<> scrobbleOrderPage
)
- [ toParam pattern, toParam pattern, toParam pattern, toParam pattern, toParam limit, toParam offset ]
+ [ toParam pattern
+ , toParam pattern
+ , toParam pattern
+ , toParam pattern
+ , toParam limit
+ , toParam offset
+ ]
pure $ mapMaybe rowToListen rows
getScrobbles conn limit offset Nothing Nothing = do
rows <- queryAll conn
[ toParam limit, toParam offset ]
pure $ mapMaybe rowToListen rows
getScrobbles conn limit offset (Just { field, value }) Nothing = do
- rows <- queryAll conn (filterQuery field) [ toParam value, toParam limit, toParam offset ]
+ rows <- queryAll conn (filterQuery field)
+ [ toParam value, toParam limit, toParam offset ]
pure $ mapMaybe rowToListen rows
filterQuery :: FilterField -> String
<> " WHERE s.track_name = ?"
<> scrobbleOrderPage
+-- | Create the release-metadata schema when it is absent.
initReleaseMetadata :: Connection -> Aff Unit
initReleaseMetadata conn = do
- run conn "CREATE TABLE IF NOT EXISTS release_metadata (release_mbid VARCHAR PRIMARY KEY, genre VARCHAR, label VARCHAR, release_year INTEGER, genre_checked_at INTEGER)" []
+ run conn
+ "CREATE TABLE IF NOT EXISTS release_metadata (release_mbid VARCHAR PRIMARY KEY, genre VARCHAR, label VARCHAR, release_year INTEGER, genre_checked_at INTEGER)"
+ []
-- Migration for existing databases; DuckDB supports IF NOT EXISTS for adding columns
- run conn "ALTER TABLE release_metadata ADD COLUMN IF NOT EXISTS genre_checked_at INTEGER" []
+ run conn
+ "ALTER TABLE release_metadata ADD COLUMN IF NOT EXISTS genre_checked_at INTEGER"
+ []
+-- | Verify that a database connection accepts queries.
ping :: Connection -> Aff Unit
ping conn = void $ queryAll conn "SELECT 1" []
+-- | List release MBIDs missing metadata, up to a limit.
getUnenrichedMbids :: Connection -> Int -> Aff (Array String)
getUnenrichedMbids conn limit = do
rows <- queryAll conn
obj <- toObject json
Object.lookup "release_mbid" obj >>= toString
+-- | List release MBIDs still missing a genre, up to a limit.
getEmptyGenreMbids :: Connection -> Int -> Aff (Array String)
getEmptyGenreMbids conn limit = do
rows <- queryAll conn
obj <- toObject json
Object.lookup "release_mbid" obj >>= toString
-upsertReleaseMetadata :: Connection -> String -> Maybe String -> Maybe String -> Maybe Int -> Aff Unit
+-- | Insert or update metadata for a MusicBrainz release.
+upsertReleaseMetadata
+ :: Connection
+ -> String
+ -> Maybe String
+ -> Maybe String
+ -> Maybe Int
+ -> Aff Unit
upsertReleaseMetadata conn mbid genre label year =
run conn
"INSERT INTO release_metadata (release_mbid, genre, label, release_year) VALUES (?, ?, ?, ?) ON CONFLICT(release_mbid) DO UPDATE SET genre=excluded.genre, label=excluded.label, release_year=excluded.release_year"
, toParam (toNullable year)
]
+-- | Mark a release genre as checked without changing its value.
touchGenreCheckedAt :: Connection -> String -> Aff Unit
touchGenreCheckedAt conn mbid = do
run conn
"UPDATE release_metadata SET genre_checked_at = CAST(epoch(now()) AS INTEGER) WHERE release_mbid = ?"
[ toParam mbid ]
-getStats :: Connection -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Aff Stats
+-- | Compute aggregated listening statistics for the requested period and section.
+getStats
+ :: Connection
+ -> Maybe String
+ -> Maybe String
+ -> Maybe String
+ -> Maybe String
+ -> Aff Stats
getStats conn mPeriod mFrom mTo mSection = do
let
- buildTimeFilterAndParams :: { timeFilter :: String, params :: Array Foreign }
+ buildTimeFilterAndParams
+ :: { timeFilter :: String, params :: Array Foreign }
buildTimeFilterAndParams = case mFrom, mTo of
Just from, Just to ->
- { timeFilter: " AND s.listened_at >= CAST(epoch(CAST(? || ' 00:00:00' AS TIMESTAMP)) AS INTEGER) AND s.listened_at < CAST(epoch(CAST(? || ' 00:00:00' AS TIMESTAMP)) AS INTEGER) + 86400"
+ { timeFilter:
+ " AND s.listened_at >= CAST(epoch(CAST(? || ' 00:00:00' AS TIMESTAMP)) AS INTEGER) AND s.listened_at < CAST(epoch(CAST(? || ' 00:00:00' AS TIMESTAMP)) AS INTEGER) + 86400"
, params: [ toParam from, toParam to ]
}
_, _ -> case mPeriod >>= Int.fromString of
Just days ->
- { timeFilter: " AND s.listened_at >= CAST(epoch(now()) AS INTEGER) - ?"
+ { timeFilter:
+ " AND s.listened_at >= CAST(epoch(now()) AS INTEGER) - ?"
, params: [ toParam (days * 86400) ]
}
Nothing ->
{ timeFilter: "", params: [] }
{ timeFilter, params: buildTimeParams } = buildTimeFilterAndParams
fetch name q extraParams = case mSection of
- Nothing -> queryAll conn (q <> " LIMIT 50") (buildTimeParams <> extraParams)
+ Nothing -> queryAll conn (q <> " LIMIT 50")
+ (buildTimeParams <> extraParams)
Just s | s == name -> queryAll conn q (buildTimeParams <> extraParams)
Just _ -> pure []
- genreRows <- fetch "genre" ("SELECT rm.genre as name, COUNT(*) as count FROM scrobbles s JOIN release_metadata rm ON s.release_mbid = rm.release_mbid WHERE rm.genre IS NOT NULL AND rm.genre != ''" <> timeFilter <> " GROUP BY rm.genre ORDER BY count DESC") []
- labelRows <- fetch "label" ("SELECT rm.label as name, COUNT(*) as count FROM scrobbles s JOIN release_metadata rm ON s.release_mbid = rm.release_mbid WHERE rm.label IS NOT NULL AND rm.label != ''" <> timeFilter <> " GROUP BY rm.label ORDER BY count DESC") []
- yearRows <- fetch "year" ("SELECT CAST(rm.release_year AS VARCHAR) as name, COUNT(*) as count FROM scrobbles s JOIN release_metadata rm ON s.release_mbid = rm.release_mbid WHERE rm.release_year IS NOT NULL" <> timeFilter <> " GROUP BY rm.release_year ORDER BY rm.release_year DESC") []
- artistRows <- fetch "artist" ("SELECT s.artist_name as name, COUNT(*) as count FROM scrobbles s WHERE s.artist_name != ''" <> timeFilter <> " GROUP BY s.artist_name ORDER BY count DESC") []
- trackRows <- fetch "track" ("SELECT s.artist_name || ' — ' || s.track_name as name, COUNT(*) as count FROM scrobbles s WHERE s.track_name != '' AND s.artist_name != ''" <> timeFilter <> " GROUP BY s.artist_name, s.track_name ORDER BY count DESC") []
- totalRows <- queryAll conn ("SELECT COUNT(*) as count FROM scrobbles s WHERE 1 = 1" <> timeFilter) buildTimeParams
+ genreRows <- fetch "genre"
+ ( "SELECT rm.genre as name, COUNT(*) as count FROM scrobbles s JOIN release_metadata rm ON s.release_mbid = rm.release_mbid WHERE rm.genre IS NOT NULL AND rm.genre != ''"
+ <> timeFilter
+ <> " GROUP BY rm.genre ORDER BY count DESC"
+ )
+ []
+ labelRows <- fetch "label"
+ ( "SELECT rm.label as name, COUNT(*) as count FROM scrobbles s JOIN release_metadata rm ON s.release_mbid = rm.release_mbid WHERE rm.label IS NOT NULL AND rm.label != ''"
+ <> timeFilter
+ <> " GROUP BY rm.label ORDER BY count DESC"
+ )
+ []
+ yearRows <- fetch "year"
+ ( "SELECT CAST(rm.release_year AS VARCHAR) as name, COUNT(*) as count FROM scrobbles s JOIN release_metadata rm ON s.release_mbid = rm.release_mbid WHERE rm.release_year IS NOT NULL"
+ <> timeFilter
+ <> " GROUP BY rm.release_year ORDER BY rm.release_year DESC"
+ )
+ []
+ artistRows <- fetch "artist"
+ ( "SELECT s.artist_name as name, COUNT(*) as count FROM scrobbles s WHERE s.artist_name != ''"
+ <> timeFilter
+ <> " GROUP BY s.artist_name ORDER BY count DESC"
+ )
+ []
+ trackRows <- fetch "track"
+ ( "SELECT s.artist_name || ' — ' || s.track_name as name, COUNT(*) as count FROM scrobbles s WHERE s.track_name != '' AND s.artist_name != ''"
+ <> timeFilter
+ <> " GROUP BY s.artist_name, s.track_name ORDER BY count DESC"
+ )
+ []
+ totalRows <- queryAll conn
+ ("SELECT COUNT(*) as count FROM scrobbles s WHERE 1 = 1" <> timeFilter)
+ buildTimeParams
pure $ Stats
{ totalScrobbles: fromMaybe 0 (totalRows !! 0 >>= rowToCount)
, genres: mapMaybe rowToEntry genreRows
obj <- toObject json
map Int.round $ Object.lookup "count" obj >>= toNumber
-getArtistReleasesByMbids :: Connection -> Array String -> Aff (Object.Object { artist :: String, release :: String })
+-- | Map release MBIDs to their locally known artist and release names.
+getArtistReleasesByMbids
+ :: Connection
+ -> Array String
+ -> Aff (Object.Object { artist :: String, release :: String })
getArtistReleasesByMbids _ mbids | null mbids = pure Object.empty
getArtistReleasesByMbids conn mbids = do
let placeholders = joinWith "," (replicate (length mbids) "?")
, genre
, label
, mbidMapping: Just $ MbidMapping
- { releaseMbid: if releaseMbid == "" then Nothing else Just releaseMbid
- , caaReleaseMbid: if caaReleaseMbid == "" then Nothing else Just caaReleaseMbid
+ { releaseMbid:
+ if releaseMbid == "" then Nothing else Just releaseMbid
+ , caaReleaseMbid:
+ if caaReleaseMbid == "" then Nothing else Just caaReleaseMbid
}
}
}
+-- | Find the owning user slug for an API token.
getTokenUser :: Connection -> String -> Aff (Maybe String)
getTokenUser conn token = do
let hashedToken = sha256 token
- rows <- queryAll conn "SELECT slug FROM api_tokens WHERE hashed_token = ?" [ toParam hashedToken ]
+ rows <- queryAll conn "SELECT slug FROM api_tokens WHERE hashed_token = ?"
+ [ toParam hashedToken ]
pure $ rows !! 0 >>= toObject >>= Object.lookup "slug" >>= toString
blob - 7b4aaa907fb652801e3f16677b13398c60efd105
blob + 76faec0bbc237f51181b97a206ba1da29075d457
--- src/Handler.purs
+++ src/Handler.purs
import Node.Encoding (Encoding(UTF8))
import Node.HTTP.OutgoingMessage (setHeader, toWriteable)
import Node.HTTP.ServerResponse (setStatusCode, toOutgoingMessage)
+import Node.HTTP.Types (IMServer, IncomingMessage, ServerResponse)
import Node.Stream (end, writeString)
-import Node.HTTP.Types (ServerResponse, IncomingMessage, IMServer)
+-- | Incoming HTTP request handled by the application server.
type Request = IncomingMessage IMServer
+-- | Outgoing HTTP response written by route handlers.
type Response = ServerResponse
+-- | Write a response with the supplied MIME type, status, and body.
respond :: String -> Int -> String -> Response -> Effect Unit
respond contentType statusCode body res = do
setHeader "Content-Type" contentType (toOutgoingMessage res)
void $ writeString w UTF8 body
end w
+-- | Write the standard 404 response.
serveNotFound :: Response -> Effect Unit
serveNotFound = respond "text/plain" 404 "Not Found"
+-- | Write the standard 401 response.
serveUnauthorized :: Response -> Effect Unit
serveUnauthorized = respond "text/plain" 401 "Unauthorized"
+-- | Write the standard 500 response.
serveInternalError :: Response -> Effect Unit
serveInternalError = respond "text/plain" 500 "Internal Server Error"
+-- | Write a 400 response with a caller-supplied message.
serveBadRequest :: Response -> String -> Effect Unit
serveBadRequest res message = respond "text/plain" 400 message res
+-- | Write an error response with an explicit status and status name.
serveError :: Response -> Int -> String -> String -> Effect Unit
serveError res statusCode statusName message =
respond "text/plain" statusCode (statusName <> ": " <> message) res
blob - e2c99105dfc0dcbd6b5d63e92b850b9760be1ddc
blob + 8a02d6b5d54031e94fab7272a82f4a874a01972b
--- src/Http.purs
+++ src/Http.purs
import Effect.Aff (Aff, delay)
import Effect.Exception (error)
--- External API calls should fail promptly so the caller can use its fallback
--- or retry policy. Cancelling Fetch's Aff aborts its underlying request.
+-- | Timeout used for external API requests.
apiTimeout :: Milliseconds
apiTimeout = Milliseconds 10_000.0
--- Image responses are larger than API payloads, but must still be bounded.
+-- | Timeout used for cover-image requests and downloads.
imageTimeout :: Milliseconds
imageTimeout = Milliseconds 20_000.0
+-- | Run an action until it finishes or the timeout expires.
withTimeout :: forall a. Milliseconds -> String -> Aff a -> Aff a
withTimeout timeout label action = do
result <- sequential $
parallel (Right <$> action)
- <|> parallel (delay timeout *> pure (Left $ error $ label <> " timed out"))
+ <|> parallel
+ (delay timeout *> pure (Left $ error $ label <> " timed out"))
case result of
Left err -> throwError err
Right value -> pure value
blob - a16e514877a824d82e83e27ad342da0773ffa37e
blob + 130971b16f140d2a2bcee9c4301bb7677e944461
--- src/Image.purs
+++ src/Image.purs
module Image (arrayBufferByteLength, convertToAvif) where
import Prelude
+
import Control.Promise (Promise, toAffE)
+import Data.ArrayBuffer.Types (ArrayBuffer)
import Effect (Effect)
import Effect.Aff (Aff)
-import Data.ArrayBuffer.Types (ArrayBuffer)
foreign import convertToAvifImpl :: ArrayBuffer -> Effect (Promise ArrayBuffer)
foreign import arrayBufferByteLengthImpl :: ArrayBuffer -> Effect Number
+-- | Convert an image buffer to AVIF.
convertToAvif :: ArrayBuffer -> Aff ArrayBuffer
convertToAvif = toAffE <<< convertToAvifImpl
+-- | Return an array buffer's byte length.
arrayBufferByteLength :: ArrayBuffer -> Effect Number
arrayBufferByteLength = arrayBufferByteLengthImpl
blob - a423eb6cf21940f59997431278c702705d768fff
blob + 85bc425c08adb1e4aec014710f9b964ab35108a1
--- src/Log.purs
+++ src/Log.purs
import Data.DateTime (DateTime)
import Data.Formatter.DateTime (FormatterCommand(..), format)
import Data.List (fromFoldable)
-import Data.String (replaceAll, Pattern(..), Replacement(..))
+import Data.String (Pattern(..), Replacement(..), replaceAll)
import Effect (Effect)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Console as Console
# replaceAll (Pattern "\r") (Replacement " ")
Console.log $ "[" <> ts <> "] [" <> show level <> "] " <> sanitized
+-- | Log an informational message.
info :: forall m. MonadEffect m => String -> m Unit
info msg = liftEffect $ logMessage INFO msg
+-- | Log a warning message.
warn :: forall m. MonadEffect m => String -> m Unit
warn msg = liftEffect $ logMessage WARN msg
+-- | Log an error message.
error :: forall m. MonadEffect m => String -> m Unit
error msg = liftEffect $ logMessage ERROR msg
blob - baaaf72ce97ec9047cf137db40a157fda3c4737b
blob + 810fc7b5d89e02067d3459dc1bf5158232e0c6a3
--- src/Mail.purs
+++ src/Mail.purs
-module Mail where
+module Mail (Mail, isConfigured, sendMail) where
import Prelude
, from :: Nullable String
}
+-- | A plaintext email to be delivered through SMTP.
type Mail =
{ to :: String
, subject :: String
blob - 3df3d5ddc7ad951e6b39d5a6a815ce30dbee0c91
blob + e891a44beb878521ecb6865a145f11f540116664
--- src/Main.purs
+++ src/Main.purs
-module Main where
+module Main
+ ( findUserByToken
+ , main
+ , parseAuthToken
+ , parseBearer
+ , sanitizeDate
+ , submitListenToListen
+ , validateTokenJson
+ ) where
import Prelude
-import Config (AppConfig, UserConfig, UserEntry, defaultUserConfig, fillUserConfigFromEnv, loadConfig, s3ConfigFromUser)
-import Cover (serveCover)
+import Command as Command
+import Config
+ ( AppConfig
+ , UserConfig
+ , UserEntry
+ , defaultUserConfig
+ , fillUserConfigFromEnv
+ , loadConfig
+ , s3ConfigFromUser
+ )
import Cosine (serveSimilar)
+import Cover (serveCover)
import Data.Argonaut (decodeJson, encodeJson, parseJson, stringify)
import Data.Array (find, length, snoc)
import Data.Array as Data.Array
import Data.Int as Int
import Data.Maybe (Maybe(..), fromMaybe)
import Data.String (Pattern(..), stripPrefix, trim)
-import Data.String.Regex (Regex, regex, replace, parseFlags)
+import Data.String.Regex (Regex, parseFlags, regex, replace)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..), fst)
-import Db (Connection, backupDb, closeConnection, connect, fromString, getOrCreateToken, getScrobbles, getStats, getTokenUser, initDb, initReleaseMetadata, ping, upsertScrobble, withTransaction)
+import Db
+ ( Connection
+ , backupDb
+ , closeConnection
+ , connect
+ , fromString
+ , getOrCreateToken
+ , getScrobbles
+ , getStats
+ , getTokenUser
+ , initDb
+ , initReleaseMetadata
+ , ping
+ , upsertScrobble
+ , withTransaction
+ )
import Effect (Effect)
import Effect.Aff (Aff, Fiber, forkAff, killFiber, launchAff_, try)
import Effect.Aff.AVar (AVar)
import Effect.Aff.AVar as Avar
import Effect.Class (liftEffect)
+import Effect.Exception as Exception
import Effect.Ref (Ref)
import Effect.Ref as Ref
-import Effect.Exception as Exception
-import Mail as Mail
-import Registrations as Reg
-import Node.Encoding (Encoding(UTF8))
+import Foreign.Object as Object
+import Handler
+ ( Request
+ , Response
+ , respond
+ , serveBadRequest
+ , serveError
+ , serveInternalError
+ , serveNotFound
+ , serveUnauthorized
+ )
import Log as Log
-import Node.EventEmitter (on_)
+import Mail as Mail
import Metadata (enrichMetadata)
import Metrics as Metrics
+import Node.Encoding (Encoding(UTF8))
+import Node.EventEmitter (on_)
import Node.FS.Aff as FSA
import Node.HTTP (createServer)
import Node.HTTP.IncomingMessage as IM
import Node.HTTP.OutgoingMessage (setHeader, toWriteable)
-import Node.HTTP.ServerResponse (setStatusCode, toOutgoingMessage)
import Node.HTTP.Server as Server
+import Node.HTTP.ServerResponse (setStatusCode, toOutgoingMessage)
import Node.Net.Server (listenTcp, listeningH)
import Node.Process (argv, lookupEnv)
import Node.Stream (end, write, writeString)
import Node.Stream.Aff (readableToStringUtf8)
+import Registrations as Reg
import Sync (lbSync, lbSyncLoop, lfSync, lfSyncLoop)
+import Templates (indexHtml)
+import Types
+ ( Listen(..)
+ , ListenBrainzAdditionalInfo(..)
+ , ListenBrainzSubmitListen(..)
+ , ListenBrainzSubmitPayload(..)
+ , ListenBrainzSubmitTrackMetadata(..)
+ , MbidMapping(..)
+ , TrackMetadata(..)
+ )
import Web.URL (URL)
import Web.URL as URL
import Web.URL.URLSearchParams as URLSearchParams
-import Command as Command
-import Handler (Request, Response, respond, serveBadRequest, serveError, serveInternalError, serveNotFound, serveUnauthorized)
-import Templates (indexHtml)
-import Types (Listen(..), ListenBrainzAdditionalInfo(..), ListenBrainzSubmitListen(..), ListenBrainzSubmitPayload(..), ListenBrainzSubmitTrackMetadata(..), MbidMapping(..), TrackMetadata(..))
-import Foreign.Object as Object
type UserContext =
{ conn :: Connection
let method = IM.method req
let rawUrl = IM.url req
contexts <- Ref.read env.contextsRef
- let allUsers = map (\ctx -> { slug: ctx.slug, name: ctx.displayName }) contexts
+ let
+ allUsers = map (\ctx -> { slug: ctx.slug, name: ctx.displayName }) contexts
case URL.fromRelative rawUrl "http://localhost" of
Nothing ->
serveNotFound res
Right _ ->
pure unit
-routeRequest :: ServerEnv -> Array UserContext -> Request -> URL -> String -> Array { slug :: String, name :: String } -> Response -> Aff Unit
+routeRequest
+ :: ServerEnv
+ -> Array UserContext
+ -> Request
+ -> URL
+ -> String
+ -> Array { slug :: String, name :: String }
+ -> Response
+ -> Aff Unit
routeRequest env contexts req url path allUsers res = liftEffect $ case path of
"/client.js" ->
serveClientJs res
"/stats" ->
withUser url \ctx -> serveStats ctx.conn url res
"/cover" ->
- withUser url \ctx -> launchAff_ $ serveCover serveNotFound ctx.config ctx.slug url res
+ withUser url \ctx -> launchAff_ $ serveCover serveNotFound ctx.config
+ ctx.slug
+ url
+ res
"/similar" ->
- withUser url \ctx -> serveSimilar serveBadRequest serveError 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
"/1/validate-token" ->
Just ctx ->
f ctx
-withUserFromToken :: Array UserContext -> Request -> Response -> (UserContext -> Aff Unit) -> Aff Unit
+withUserFromToken
+ :: Array UserContext
+ -> Request
+ -> Response
+ -> (UserContext -> Aff Unit)
+ -> Aff Unit
withUserFromToken contextsParam reqParam resParam f = do
- let mToken = parseAuthToken (Object.lookup "authorization" (IM.headers reqParam))
+ let
+ mToken = parseAuthToken
+ (Object.lookup "authorization" (IM.headers reqParam))
case mToken of
Nothing -> liftEffect $ do
Log.warn "Missing or invalid Authorization header"
-- `{"valid": true, "user_name": ...}` response, otherwise they refuse to scrobble.
serveValidateToken :: Array UserContext -> Request -> Response -> Aff Unit
serveValidateToken contextsParam reqParam resParam = do
- let mToken = parseAuthToken (Object.lookup "authorization" (IM.headers reqParam))
+ let
+ mToken = parseAuthToken
+ (Object.lookup "authorization" (IM.headers reqParam))
case mToken of
Nothing -> liftEffect $ do
Log.warn "validate-token: missing or invalid Authorization header"
resParam
-- Extract a ListenBrainz API token from an `Authorization: Token <token>` header value.
+-- | Extract a token from the API's `Token` authorization scheme.
parseAuthToken :: Maybe String -> Maybe String
parseAuthToken mAuth = do
token <- mAuth >>= stripPrefix (Pattern "Token ")
-- Build the `validate-token` response body. `Just displayName` means the token
-- resolved to a user (valid); `Nothing` means the token is unknown (invalid).
-- The shape mirrors the real ListenBrainz API so clients like Navidrome accept it.
+-- | Render a token-validation response body.
validateTokenJson :: Maybe String -> String
validateTokenJson Nothing =
"""{"code":200,"message":"Token invalid.","valid":false}"""
, user_name: displayName
}
+-- | Find the active user context that owns an API token.
findUserByToken :: Array UserContext -> String -> Aff (Maybe UserContext)
findUserByToken contexts tokenValue = case Data.Array.uncons contexts of
Nothing ->
_ ->
findUserByToken rest tokenValue
-serveIndex :: Boolean -> Array { slug :: String, name :: String } -> String -> Response -> Effect Unit
+serveIndex
+ :: Boolean
+ -> Array { slug :: String, name :: String }
+ -> String
+ -> Response
+ -> Effect Unit
serveIndex registrationEnabled allUsers slug res = do
setHeader "Content-Type" "text/html" (toOutgoingMessage res)
setStatusCode 200 res
serveConflict res message = respond "text/plain" 409 message res
-- Extract an admin secret from an `Authorization: Bearer <token>` header value.
+-- | Extract a token from the `Bearer` authorization scheme.
parseBearer :: Maybe String -> Maybe String
parseBearer mAuth = do
token <- mAuth >>= stripPrefix (Pattern "Bearer ")
if displayName == "" || email == "" then
liftEffect $ serveBadRequest res "Name and email are required"
else if not (Reg.validSlugFormat slug) then
- liftEffect $ serveBadRequest res "Invalid username: use lowercase letters, numbers and dashes"
+ liftEffect $ serveBadRequest res
+ "Invalid username: use lowercase letters, numbers and dashes"
else if Reg.isReservedSlug slug || elem slug existingSlugs then
liftEffect $ serveConflict res "That username is already taken"
else do
taken <- Reg.slugTaken env.regConn slug
if taken then
- liftEffect $ serveConflict res "That username has already been requested"
+ liftEffect $ serveConflict res
+ "That username has already been requested"
else do
Reg.insertRegistration env.regConn env.regLock
{ slug, displayName, email, listenbrainzUser: lb, lastfmUser: lf }
notifyAdminNewRegistration env slug displayName email
- liftEffect $ respond "application/json" 200 """{"status":"ok"}""" res
+ liftEffect $ respond "application/json" 200 """{"status":"ok"}"""
+ res
serveListRegistrations :: ServerEnv -> Response -> Aff Unit
serveListRegistrations env res = do
regs <- Reg.listByStatus env.regConn "pending"
- liftEffect $ respond "application/json" 200 (stringify $ encodeJson (map regToJson regs)) res
+ liftEffect $ respond "application/json" 200
+ (stringify $ encodeJson (map regToJson regs))
+ res
regToJson
:: Reg.Registration
- -> { id :: String, slug :: String, name :: String, email :: String, listenbrainzUser :: Maybe String, lastfmUser :: Maybe String, status :: String, createdAt :: Int }
+ -> { id :: String
+ , slug :: String
+ , name :: String
+ , email :: String
+ , listenbrainzUser :: Maybe String
+ , lastfmUser :: Maybe String
+ , status :: String
+ , createdAt :: Int
+ }
regToJson r =
{ id: r.id
, slug: r.slug
result <- try $ provisionUser env reg
case result of
Left err -> do
- Log.error $ "Failed to provision user '" <> reg.slug <> "': " <> Exception.message err
+ Log.error $ "Failed to provision user '" <> reg.slug <> "': "
+ <> Exception.message err
liftEffect $ serveInternalError res
Right mToken -> do
Reg.setStatus env.regConn env.regLock id "approved"
notifyApproved env reg mToken
liftEffect $ respond "application/json" 200
- (stringify $ encodeJson { status: "approved", token: mToken })
+ ( stringify $ encodeJson
+ { status: "approved", token: mToken }
+ )
res
serveDeny :: ServerEnv -> Request -> Response -> Aff Unit
else do
Reg.setStatus env.regConn env.regLock id "denied"
notifyDenied env reg
- liftEffect $ respond "application/json" 200 """{"status":"denied"}""" res
+ liftEffect $ respond "application/json" 200
+ """{"status":"denied"}"""
+ res
-- Lists the currently-registered (approved) users.
serveListUsers :: ServerEnv -> Response -> Aff Unit
serveListUsers env res = do
regs <- Reg.listByStatus env.regConn "approved"
contexts <- liftEffect $ Ref.read env.contextsRef
- let isLiveRegistered reg = any (\ctx -> ctx.slug == reg.slug && ctx.isRegistered) contexts
- liftEffect $ respond "application/json" 200 (stringify $ encodeJson (map regToJson $ Data.Array.filter isLiveRegistered regs)) res
+ let
+ isLiveRegistered reg = any
+ (\ctx -> ctx.slug == reg.slug && ctx.isRegistered)
+ contexts
+ liftEffect $ respond "application/json" 200
+ ( stringify $ encodeJson
+ (map regToJson $ Data.Array.filter isLiveRegistered regs)
+ )
+ res
serveRemoveUser :: ServerEnv -> Request -> Response -> Aff Unit
serveRemoveUser env req res = do
else do
removed <- removeUser env reg
if removed then
- liftEffect $ respond "application/json" 200 """{"status":"removed"}""" res
+ liftEffect $ respond "application/json" 200
+ """{"status":"removed"}"""
+ res
else
- liftEffect $ serveBadRequest res "User is not an active self-registered user"
+ liftEffect $ serveBadRequest res
+ "User is not an active self-registered user"
-- Removes an approved user: stops its fibers, drops it from the live set,
-- deletes its database file, and marks the registration 'revoked' (so it stays
pure false
Just ctx -> do
cleanupUser ctx
- liftEffect $ Ref.modify_ (Data.Array.filter (\c -> c.slug /= reg.slug || not c.isRegistered)) env.contextsRef
+ liftEffect $ Ref.modify_
+ (Data.Array.filter (\c -> c.slug /= reg.slug || not c.isRegistered))
+ env.contextsRef
void $ try $ closeConnection ctx.conn
void $ try $ FSA.unlink ctx.config.databaseFile
Reg.setStatus env.regConn env.regLock reg.id "revoked"
-- Builds a runnable UserEntry from an approved registration (users.json is not touched).
registrationUserEntry :: Reg.Registration -> Aff UserEntry
registrationUserEntry reg = do
- let base = defaultUserConfig ("corpus-" <> reg.slug <> ".db") reg.listenbrainzUser reg.lastfmUser
+ let
+ base = defaultUserConfig ("corpus-" <> reg.slug <> ".db")
+ reg.listenbrainzUser
+ reg.lastfmUser
config <- fillUserConfigFromEnv base
pure { slug: reg.slug, name: Just reg.displayName, config }
if Mail.isConfigured env.appConfig.smtp then do
result <- try $ Mail.sendMail env.appConfig.smtp mail
case result of
- Left err -> Log.error $ "Failed to send email to " <> mail.to <> ": " <> Exception.message err
+ Left err -> Log.error $ "Failed to send email to " <> mail.to <> ": " <>
+ Exception.message err
Right _ -> Log.info $ "Sent email to " <> mail.to
else
Log.warn "SMTP not configured; skipping email"
-notifyAdminNewRegistration :: ServerEnv -> String -> String -> String -> Aff Unit
+notifyAdminNewRegistration
+ :: ServerEnv -> String -> String -> String -> Aff Unit
notifyAdminNewRegistration env slug displayName email =
for_ env.appConfig.adminEmail \adminAddr ->
sendMailBestEffort env
void $ writeString w UTF8 responseBody
end w
+-- | Retain only ISO-date characters accepted by the statistics API.
sanitizeDate :: String -> String
sanitizeDate s = case sanitizeDateRe of
Nothing -> s
void $ writeString w UTF8 """{"status":"ok"}"""
Left err -> do
setStatusCode 503 res
- void $ writeString w UTF8 $ """{"status":"error","message":""" <> show (Exception.message err) <> "}"
+ void $ writeString w UTF8 $ """{"status":"error","message":"""
+ <> show (Exception.message err)
+ <> "}"
end w
-serveSubmitListens :: String -> Connection -> AVar Unit -> Request -> Response -> Aff Unit
+serveSubmitListens
+ :: String -> Connection -> AVar Unit -> Request -> Response -> Aff Unit
serveSubmitListens slug db lock req res = do
body <- readableToStringUtf8 (IM.toReadable req)
case parseJson body >>= decodeJson of
Left err ->
liftEffect $ serveBadRequest res $ "Invalid JSON: " <> show err
Right (ListenBrainzSubmitPayload { listenType, payload }) -> do
- let listens = Data.Array.mapMaybe (submitListenToListen listenType) payload
+ let
+ listens = Data.Array.mapMaybe (submitListenToListen listenType) payload
withTransaction db lock $ traverse_ (upsertScrobble db) listens
liftEffect $ do
Metrics.incSyncScrobbles slug "api" (length listens)
void $ writeString w UTF8 """{"status":"ok"}"""
end w
+-- | Convert an accepted ListenBrainz submission to a local listen.
submitListenToListen :: String -> ListenBrainzSubmitListen -> Maybe Listen
-submitListenToListen "single" (ListenBrainzSubmitListen { listenedAt, trackMetadata }) =
+submitListenToListen
+ "single"
+ (ListenBrainzSubmitListen { listenedAt, trackMetadata }) =
Just $ Listen
{ listenedAt
, trackMetadata: submitTrackMetadataToTrackMetadata trackMetadata
}
-submitListenToListen "import" (ListenBrainzSubmitListen { listenedAt, trackMetadata }) =
+submitListenToListen
+ "import"
+ (ListenBrainzSubmitListen { listenedAt, trackMetadata }) =
Just $ Listen
{ listenedAt
, trackMetadata: submitTrackMetadataToTrackMetadata trackMetadata
submitListenToListen "playing_now" _ = Nothing
submitListenToListen _ _ = Nothing
-submitTrackMetadataToTrackMetadata :: ListenBrainzSubmitTrackMetadata -> TrackMetadata
-submitTrackMetadataToTrackMetadata (ListenBrainzSubmitTrackMetadata { trackName, artistName, releaseName, additionalInfo }) =
+submitTrackMetadataToTrackMetadata
+ :: ListenBrainzSubmitTrackMetadata -> TrackMetadata
+submitTrackMetadataToTrackMetadata
+ ( ListenBrainzSubmitTrackMetadata
+ { trackName, artistName, releaseName, additionalInfo }
+ ) =
TrackMetadata
{ trackName: Just trackName
, artistName: Just artistName
Log.info $ "User '" <> slug <> "' token: " <> token
case config.lastfmUser, config.lastfmApiKey of
- Just _, Nothing -> Log.warn $ "User '" <> slug <> "': Last.fm sync disabled (missing API key)"
+ Just _, Nothing -> Log.warn $ "User '" <> slug <>
+ "': Last.fm sync disabled (missing API key)"
_, _ -> pure unit
initialSyncFibers <- traverse forkAff
Just username -> Just $ lbSync conn username slug writeLock
Nothing -> Nothing
, case config.lastfmUser, config.lastfmApiKey of
- Just lfmUser, Just apiKey -> Just $ lfSync conn apiKey lfmUser slug writeLock
+ Just lfmUser, Just apiKey -> Just $ lfSync conn apiKey lfmUser slug
+ writeLock
_, _ -> Nothing
] # Data.Array.mapMaybe identity
Just username -> Just $ lbSyncLoop conn username slug writeLock
Nothing -> Nothing
, case config.lastfmUser, config.lastfmApiKey of
- Just lfmUser, Just apiKey -> Just $ lfSyncLoop conn apiKey lfmUser slug writeLock
+ Just lfmUser, Just apiKey -> Just $ lfSyncLoop conn apiKey lfmUser
+ slug
+ writeLock
_, _ -> Nothing
] # Data.Array.mapMaybe identity
enrichMetadataFiber <- forkAff $ enrichMetadata conn config slug
backupFiber <-
- if config.backupEnabled then Just <$> forkAff (backupDb conn config.databaseFile (s3ConfigFromUser config) (Int.toNumber config.backupIntervalHours * 3600000.0) slug)
+ if config.backupEnabled then Just <$> forkAff
+ ( backupDb conn config.databaseFile (s3ConfigFromUser config)
+ (Int.toNumber config.backupIntervalHours * 3600000.0)
+ slug
+ )
else pure Nothing
let displayName = fromMaybe (if slug == "" then "root" else slug) name
pure $ Tuple
- { conn, writeLock, config, slug, displayName, isRegistered, initialSyncFibers, enrichMetadataFiber: Just enrichMetadataFiber, backupFiber, syncFibers: loopFibers }
+ { conn
+ , writeLock
+ , config
+ , slug
+ , displayName
+ , isRegistered
+ , initialSyncFibers
+ , enrichMetadataFiber: Just enrichMetadataFiber
+ , backupFiber
+ , syncFibers: loopFibers
+ }
mToken
cleanupUser :: UserContext -> Aff Unit
foreign import dotenvConfig :: Effect Unit
+-- | Load configuration and start the HTTP service.
main :: Effect Unit
main = do
dotenvConfig
launchAff_ do
- configFile <- liftEffect $ map (fromMaybe "users.json") $ lookupEnv "CORPUS_USERS_FILE"
+ configFile <- liftEffect $ map (fromMaybe "users.json") $ lookupEnv
+ "CORPUS_USERS_FILE"
args <- liftEffect argv
let commandArgs = Data.Array.drop 2 args
case Data.Array.uncons commandArgs of
result <- try $ loadConfig configFile
case result of
Left err -> do
- Log.error $ "Failed to load " <> configFile <> ": " <> Exception.message err
+ Log.error $ "Failed to load " <> configFile <> ": " <>
+ Exception.message err
liftEffect $ Exception.throwException err
Right (appConfig :: AppConfig) -> do
- Log.info $ "Loaded " <> show (length appConfig.users) <> " user(s) from " <> configFile
+ Log.info $ "Loaded " <> show (length appConfig.users)
+ <> " user(s) from "
+ <> configFile
results <- traverse (startUser false) appConfig.users
let jsonContexts = map fst results
-- Also start approved registrations, skipping slugs already in users.json.
Reg.initRegistrations regConn
approved <- Reg.listByStatus regConn "approved"
let jsonSlugs = map _.slug jsonContexts
- let toStart = Data.Array.filter (\r -> not (elem r.slug jsonSlugs)) approved
+ let
+ toStart = Data.Array.filter (\r -> not (elem r.slug jsonSlugs))
+ approved
when (not (Data.Array.null toStart))
$ Log.info
- $ "Starting " <> show (length toStart) <> " approved registered user(s)"
+ $ "Starting " <> show (length toStart) <>
+ " approved registered user(s)"
approvedEntries <- traverse registrationUserEntry toStart
approvedResults <- traverse (startUser true) approvedEntries
let contexts = jsonContexts <> map fst approvedResults
let netServer = Server.toNetServer server
netServer # on_ listeningH do
- Log.info $ "Server is running on " <> appConfig.host <> ":" <> show appConfig.port
+ Log.info $ "Server is running on " <> appConfig.host <> ":" <>
+ show appConfig.port
- listenTcp netServer { host: appConfig.host, port: appConfig.port, backlog: 128 }
+ listenTcp netServer
+ { host: appConfig.host, port: appConfig.port, backlog: 128 }
blob - 3400d5f40aa7df418812239b9f8cfbbf27b3385c
blob + b27ab726d8331e914d04f07398fdc2edde631c29
--- src/Metadata.purs
+++ src/Metadata.purs
import Config (UserConfig)
import Control.Monad.Rec.Class (forever)
-import Data.Array ((!!), length, null)
+import Data.Argonaut.Core (toArray, toObject, toString)
+import Data.Array (length, null, (!!))
import Data.Either (Either(..))
import Data.Foldable (foldM, for_)
import Data.Int (fromString)
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 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 (Method(GET), fetch)
import Fetch.Argonaut.Json (fromJson)
import Foreign.Object as Object
-import JSURI (encodeURIComponent)
import Http (apiTimeout, withTimeout)
+import JSURI (encodeURIComponent)
import Log as Log
import Metrics as Metrics
-type MbData = { genre :: Maybe String, label :: Maybe String, year :: Maybe Int }
+-- | Metadata extracted from a MusicBrainz release response.
+type MbData =
+ { genre :: Maybe String, label :: Maybe String, year :: Maybe Int }
+-- | Optional genre fallback source.
type GenreSource =
{ name :: String
, enabled :: Boolean
, fetch :: Aff (Maybe String)
}
+-- | Fetch genre, label, and release year from MusicBrainz.
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 $ withTimeout apiTimeout "MusicBrainz metadata lookup" $ fetch url { method: GET, headers: { "User-Agent": "corpus/1.0 +https://sr.ht/~mtmn/corpus" } }
+ let
+ url = "https://musicbrainz.org/ws/2/release/" <> mbid <>
+ "?inc=genres+labels+release-groups&fmt=json"
+ result <- try $ withTimeout apiTimeout "MusicBrainz metadata lookup" $ fetch
+ url
+ { method: GET
+ , headers: { "User-Agent": "corpus/1.0 +https://sr.ht/~mtmn/corpus" }
+ }
case result of
Left err -> do
- Log.error $ "MusicBrainz fetch error for " <> mbid <> ": " <> Exception.message err
+ 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
+ Log.error $ "MusicBrainz JSON parse error for " <> mbid <> ": " <>
+ Exception.message err
pure $ Just { genre: Nothing, label: Nothing, year: Nothing }
Right json -> do
let
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
+ 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"
+ $ "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"
+ Log.warn $ "MusicBrainz " <> show fr.status <> " for " <> mbid <>
+ ", will retry"
pure Nothing
+-- | Fetch the first Last.fm genre for an artist and release.
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
+ 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 $ withTimeout apiTimeout "Last.fm genre lookup" $ fetch searchUrl { method: GET }
+ result <- try $ withTimeout apiTimeout "Last.fm genre lookup" $ fetch
+ searchUrl
+ { method: GET }
case result of
Right fetchRes | fetchRes.status == 200 -> do
jsonResult <- try $ fromJson fetchRes.json
Log.warn "Last.fm genre API request failed"
pure Nothing
+-- | Fetch the first Discogs genre for an artist and release.
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"
+ 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 $ withTimeout apiTimeout "Discogs genre lookup" $ fetch searchUrl { method: GET, headers: { "User-Agent": "corpus/1.0 +https://sr.ht/~mtmn/corpus", "Authorization": "Discogs token=" <> t } }
+ result <- try $ withTimeout apiTimeout "Discogs genre lookup" $ fetch
+ searchUrl
+ { method: GET
+ , headers:
+ { "User-Agent": "corpus/1.0 +https://sr.ht/~mtmn/corpus"
+ , "Authorization": "Discogs token=" <> t
+ }
+ }
case result of
Right fetchRes | fetchRes.status == 200 -> do
jsonResult <- try $ fromJson fetchRes.json
Log.warn "Discogs genre API request failed"
pure Nothing
+-- | Return the first genre found by the enabled fallback sources.
fetchFallbackGenre :: String -> Array GenreSource -> Aff (Maybe String)
fetchFallbackGenre slug = foldM trySource Nothing
where
Nothing -> Metrics.incEnrichmentFetch slug name "not_found"
pure result
+-- | Continuously enrich missing release metadata for one user database.
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)
+ 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"
+ 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)
-- Nothing represents a transient request failure. Do not create an
-- empty metadata row or mark the release checked: both would hide it
-- from the enrichment queue and turn a retry into a week-long skip.
- Log.warn $ "Deferring metadata enrichment for " <> mbid <> " after transient MusicBrainz failure"
+ Log.warn $ "Deferring metadata enrichment for " <> mbid <>
+ " after transient MusicBrainz failure"
Right (Just mbdata) -> do
liftEffect $ Metrics.incEnrichmentFetch slug "musicbrainz" "success"
case mbdata.genre of
Just _ ->
- upsertReleaseMetadata conn mbid mbdata.genre mbdata.label mbdata.year
+ 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 }
+ [ { 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
+ upsertReleaseMetadata conn mbid finalGenre mbdata.label
+ mbdata.year
case finalGenre of
Just genre ->
- Log.info $ "Added fallback genre for " <> mbid <> ": " <> 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
+ 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
blob - 5819d21449bddb9492fc0af1a7c100160eaa2d6c
blob + 0597573964735ccbd580827b3a9caeccc1bace31
--- src/Metrics.purs
+++ src/Metrics.purs
-module Metrics where
+module Metrics
+ ( getContentType
+ , getMetrics
+ , incCosineRequest
+ , incCoverRequest
+ , incDbBackupRun
+ , incEnrichmentFetch
+ , incSyncRuns
+ , incSyncScrobbles
+ , setDbBackupLastSuccess
+ , setEnrichmentQueueSize
+ , setSyncLastSuccess
+ , wrapRequest
+ ) where
import Prelude
import Node.HTTP.Types (IMServer, IncomingMessage, ServerResponse)
-- | Async: serialises all registered metrics to Prometheus text format.
-foreign import getMetricsImpl :: Fn2 (String -> Effect Unit) (String -> Effect Unit) (Effect Unit)
+foreign import getMetricsImpl
+ :: Fn2 (String -> Effect Unit) (String -> Effect Unit) (Effect Unit)
-- | The MIME type to use for the /metrics response body.
foreign import getContentType :: Effect String
-- | Attaches a 'finish' listener to record metrics and log the request.
-foreign import wrapRequestImpl :: Fn6 String String (String -> Effect Unit) (IncomingMessage IMServer) ServerResponse (Effect Unit) (Effect Unit)
+foreign import wrapRequestImpl
+ :: Fn6 String String (String -> Effect Unit) (IncomingMessage IMServer)
+ ServerResponse
+ (Effect Unit)
+ (Effect Unit)
-- Sync
foreign import incSyncRunsImpl :: Fn3 String String String (Effect Unit)
-- Database backup
foreign import incDbBackupRunImpl :: Fn2 String String (Effect Unit)
+-- | Record the timestamp of a successful database backup.
foreign import setDbBackupLastSuccess :: String -> Effect Unit
+-- | Collect all registered metrics in Prometheus text exposition format.
getMetrics :: Aff String
getMetrics = makeAff \cb -> do
runFn2 getMetricsImpl
(\e -> cb (Left (error e)))
pure nonCanceler
-wrapRequest :: String -> String -> (String -> Effect Unit) -> IncomingMessage IMServer -> ServerResponse -> Effect Unit -> Effect Unit
-wrapRequest method path logFn req res handler = runFn6 wrapRequestImpl method path logFn req res handler
+-- | Record request metrics after the supplied HTTP handler finishes.
+wrapRequest
+ :: String
+ -> String
+ -> (String -> Effect Unit)
+ -> IncomingMessage IMServer
+ -> ServerResponse
+ -> Effect Unit
+ -> Effect Unit
+wrapRequest method path logFn req res handler = runFn6 wrapRequestImpl method
+ path
+ logFn
+ req
+ res
+ handler
+-- | Increment a sync-run counter for a user, source, and outcome.
incSyncRuns :: String -> String -> String -> Effect Unit
incSyncRuns u s r = runFn3 incSyncRunsImpl u s r
+-- | Add accepted scrobbles to the source-specific counter.
incSyncScrobbles :: String -> String -> Int -> Effect Unit
incSyncScrobbles u s c = runFn3 incSyncScrobblesImpl u s c
+-- | Record the timestamp of a successful user sync.
setSyncLastSuccess :: String -> String -> Effect Unit
setSyncLastSuccess u s = runFn2 setSyncLastSuccessImpl u s
+-- | Increment a metadata-enrichment fetch outcome counter.
incEnrichmentFetch :: String -> String -> String -> Effect Unit
incEnrichmentFetch u s r = runFn3 incEnrichmentFetchImpl u s r
+-- | Set the current metadata-enrichment queue size.
setEnrichmentQueueSize :: String -> String -> Int -> Effect Unit
setEnrichmentQueueSize u t n = runFn3 setEnrichmentQueueSizeImpl u t n
+-- | Increment a cover-art request outcome counter.
incCoverRequest :: String -> String -> String -> Effect Unit
incCoverRequest u s r = runFn3 incCoverRequestImpl u s r
+-- | Increment a Cosine Club request outcome counter.
incCosineRequest :: String -> String -> Effect Unit
incCosineRequest u r = runFn2 incCosineRequestImpl u r
+-- | Increment a database-backup outcome counter.
incDbBackupRun :: String -> String -> Effect Unit
incDbBackupRun u r = runFn2 incDbBackupRunImpl u r
blob - d7b603af4cde642bc457bef5c84c662913e9fa2f
blob + e767e31c52a01573eaeb6f2b7e89a5d74e506609
--- src/Registrations.purs
+++ src/Registrations.purs
-module Registrations where
+module Registrations
+ ( NewRegistration
+ , Registration
+ , getById
+ , initRegistrations
+ , insertRegistration
+ , isReservedSlug
+ , listByStatus
+ , setStatus
+ , slugTaken
+ , validSlugFormat
+ ) where
import Prelude
import Effect.Now (now)
import Foreign.Object as Object
--- A registration request. status is 'pending' | 'approved' | 'denied'; createdAt is unix seconds.
+-- | A registration request; timestamps are Unix seconds.
type Registration =
{ id :: String
, slug :: String
, createdAt :: Int
}
--- Fields supplied by the public registration form.
+-- | Fields supplied by the public registration form.
type NewRegistration =
{ slug :: String
, displayName :: String
slugRegex :: Maybe Regex
slugRegex = hush $ regex "^[a-z0-9](?:[a-z0-9-]*[a-z0-9])?$" noFlags
--- Slug must be lowercase alphanumeric/dashes (not starting/ending with a dash).
+-- | Test whether a slug is lowercase alphanumeric/dashes and has valid edges.
validSlugFormat :: String -> Boolean
validSlugFormat slug = case slugRegex of
Nothing -> false
Just re -> test re slug
+-- | Test whether a slug collides with a built-in route.
isReservedSlug :: String -> Boolean
isReservedSlug slug = elem slug reservedSlugs
+-- | Create the registrations table when necessary.
initRegistrations :: Connection -> Aff Unit
initRegistrations conn =
run conn
pure $ Int.round (ms / 1000.0)
-- True if a pending or approved registration already claims this slug (denied ones don't).
+-- | Test whether a pending or approved registration owns a slug.
slugTaken :: Connection -> String -> Aff Boolean
slugTaken conn slug = do
rows <- queryAll conn
[ toParam slug ]
pure $ not (null rows)
+-- | Insert a pending registration under the shared write lock.
insertRegistration :: Connection -> AVar Unit -> NewRegistration -> Aff Unit
insertRegistration conn lock r = do
id <- liftEffect $ map UUID.toString UUID.genUUID
, toParam createdAt
]
+-- | List registrations with a given status.
listByStatus :: Connection -> String -> Aff (Array Registration)
listByStatus conn status = do
rows <- queryAll conn
[ toParam status ]
pure $ mapMaybe decodeRow rows
+-- | Retrieve a registration by its generated ID.
getById :: Connection -> String -> Aff (Maybe Registration)
getById conn id = do
rows <- queryAll conn
[ r ] -> Just r
_ -> Nothing
+-- | Update a registration status under the shared write lock.
setStatus :: Connection -> AVar Unit -> String -> String -> Aff Unit
setStatus conn lock id status = do
decidedAt <- liftEffect nowSeconds
id <- str "id"
slug <- str "slug"
status <- str "status"
- let createdAt = fromMaybe 0 $ Int.fromNumber =<< (Object.lookup "created_at" obj >>= toNumber)
+ let
+ createdAt = fromMaybe 0 $ Int.fromNumber =<<
+ (Object.lookup "created_at" obj >>= toNumber)
pure
{ id
, slug
blob - d830d47934c4ecd195aa04cba46b1c9890a7f7a7
blob + 89d2ec927001ca88d43607c4ec8a5456ebbc3378
--- src/S3.purs
+++ src/S3.purs
-module S3 where
+module S3 (existsInS3, getPresignedUrl, uploadToS3) where
import Prelude
}
foreign import uploadToS3Impl
- :: Fn5 S3ConfigJs String Buffer String (Nullable Error -> Effect Unit) (Effect Unit)
+ :: Fn5 S3ConfigJs String Buffer String (Nullable Error -> Effect Unit)
+ (Effect Unit)
foreign import existsInS3Impl
- :: Fn3 S3ConfigJs String (Nullable Error -> Boolean -> Effect Unit) (Effect Unit)
+ :: Fn3 S3ConfigJs String (Nullable Error -> Boolean -> Effect Unit)
+ (Effect Unit)
foreign import getPresignedUrlImpl
- :: Fn3 S3ConfigJs String (Nullable Error -> String -> Effect Unit) (Effect Unit)
+ :: Fn3 S3ConfigJs String (Nullable Error -> String -> Effect Unit)
+ (Effect Unit)
+-- | Upload a buffer to S3-compatible object storage.
uploadToS3 :: S3Config -> String -> Buffer -> String -> Aff Unit
uploadToS3 cfg key body contentType = makeAff \cb -> do
runFn5 uploadToS3Impl (toJs cfg) key body contentType \err ->
Nothing -> cb (Right unit)
pure nonCanceler
+-- | Check whether an S3 object exists.
existsInS3 :: S3Config -> String -> Aff Boolean
existsInS3 cfg key = makeAff \cb -> do
runFn3 existsInS3Impl (toJs cfg) key \err exists ->
Nothing -> cb (Right exists)
pure nonCanceler
+-- | Generate a one-day presigned GET URL for an S3 object.
getPresignedUrl :: S3Config -> String -> Aff String
getPresignedUrl cfg key = makeAff \cb -> do
runFn3 getPresignedUrlImpl (toJs cfg) key \err url ->
blob - 444a12315483446cb27475bcb291225cb594ab56
blob + f814a3473df08c91ec528a3e3e70cda9cb256c8a
--- src/Sync.purs
+++ src/Sync.purs
import Data.Maybe (Maybe(..), fromMaybe)
import Data.String (Pattern(..), stripPrefix)
import Data.Time.Duration (Milliseconds(..))
-import Db (Connection, checkExists, getOldestTs, upsertScrobble, withTransaction)
+import Db
+ ( Connection
+ , checkExists
+ , getOldestTs
+ , upsertScrobble
+ , withTransaction
+ )
import Effect.Aff (Aff, delay, throwError, try)
import Effect.Aff.AVar (AVar)
-import Effect.Aff.Retry (RetryStatus(..), exponentialBackoff, limitRetries, recovering)
+import Effect.Aff.Retry
+ ( RetryStatus(..)
+ , exponentialBackoff
+ , limitRetries
+ , recovering
+ )
import Effect.Class (liftEffect)
import Effect.Exception (error, message)
-import Fetch (fetch, Method(GET))
+import Fetch (Method(GET), fetch)
import Fetch.Argonaut.Json (fromJson)
-import JSURI (encodeURIComponent)
import Http (apiTimeout, withTimeout)
+import JSURI (encodeURIComponent)
import Log as Log
import Metrics as Metrics
-import Types (Listen(..), ListenBrainzResponse(..), MbidMapping(..), Payload(..), TrackMetadata(..), LastfmResponse(..), LastfmRecentTracks(..), LastfmAttr(..), LastfmTracks(..), LastfmArtist(..), LastfmAlbum(..), LastfmDate(..), LastfmTrack(..))
+import Types
+ ( LastfmAlbum(..)
+ , LastfmArtist(..)
+ , LastfmAttr(..)
+ , LastfmDate(..)
+ , LastfmRecentTracks(..)
+ , LastfmResponse(..)
+ , LastfmTrack(..)
+ , LastfmTracks(..)
+ , Listen(..)
+ , ListenBrainzResponse(..)
+ , MbidMapping(..)
+ , Payload(..)
+ , TrackMetadata(..)
+ )
-- | Result of processing a batch of listens/scrobbles.
type SyncResult =
Log.warn "Skipping scrobble without timestamp"
pure s
+-- | Build the ListenBrainz listens endpoint for a username.
listenBrainzUrl :: String -> String
-listenBrainzUrl username = "https://api.listenbrainz.org/1/user/" <> username <> "/listens"
+listenBrainzUrl username = "https://api.listenbrainz.org/1/user/" <> username <>
+ "/listens"
-- | Retry an action with exponential backoff, but only for transient errors.
-- | Parse errors and other permanent failures are not retried.
withRetry :: forall a. String -> Aff a -> Aff a
-withRetry label action = recovering policy [ \_ err -> pure $ isTransientError err ] \(RetryStatus status) -> do
- when (status.iterNumber > 0)
- $ Log.warn
- $ label <> " failed, retry attempt " <> show status.iterNumber
- action
+withRetry label action = recovering policy
+ [ \_ err -> pure $ isTransientError err ]
+ \(RetryStatus status) -> do
+ when (status.iterNumber > 0)
+ $ Log.warn
+ $ label <> " failed, retry attempt " <> show status.iterNumber
+ action
where
policy = exponentialBackoff (Milliseconds 1000.0) <> limitRetries 5
isTransientError err = not isPermanent
fetchListenBrainzUrl :: String -> Aff String
fetchListenBrainzUrl url = withRetry "ListenBrainz fetch" do
let headers = { "User-Agent": "corpus/1.0 (+https://sr.ht/~mtmn/corpus)" }
- fr <- withTimeout apiTimeout "ListenBrainz fetch" $ fetch url { method: GET, headers }
+ fr <- withTimeout apiTimeout "ListenBrainz fetch" $ fetch url
+ { method: GET, headers }
if fr.status == 200 then
withTimeout apiTimeout "ListenBrainz response" fr.text
else
throwError $ error $ "ListenBrainz API returned status " <> show fr.status
-fetchLastfmPage :: String -> String -> Int -> Maybe Int -> Aff { tracks :: Array Json, totalPages :: Int }
+-- | Fetch and decode one Last.fm recent-tracks page.
+fetchLastfmPage
+ :: String
+ -> String
+ -> Int
+ -> Maybe Int
+ -> Aff { tracks :: Array Json, totalPages :: Int }
fetchLastfmPage apiKey lfmUser page mTo = withRetry "Last.fm fetch" do
let
toParam = case mTo of
Just ts -> "&to=" <> show ts
Nothing -> ""
- baseUrl = "https://ws.audioscrobbler.com/2.0/?method=user.getrecenttracks&user="
- <> (fromMaybe lfmUser $ encodeURIComponent lfmUser)
- <> "&format=json&limit=200&page="
- <> show page
- <> toParam
+ baseUrl =
+ "https://ws.audioscrobbler.com/2.0/?method=user.getrecenttracks&user="
+ <> (fromMaybe lfmUser $ encodeURIComponent lfmUser)
+ <> "&format=json&limit=200&page="
+ <> show page
+ <> toParam
url = baseUrl <> "&api_key=" <> apiKey
let headers = { "User-Agent": "corpus/1.0 (+https://sr.ht/~mtmn/corpus)" }
- fr <- withTimeout apiTimeout "Last.fm sync fetch" $ fetch url { method: GET, headers }
+ fr <- withTimeout apiTimeout "Last.fm sync fetch" $ fetch url
+ { method: GET, headers }
if fr.status == 200 then do
json <- fromJson fr.json
case parseLastfmResponse json of
else do
throwError $ error ("Last.fm API returned status " <> show fr.status)
+-- | Parse a Last.fm page into tracks and its total-page count.
parseLastfmResponse :: Json -> Maybe { tracks :: Array Json, totalPages :: Int }
parseLastfmResponse json = case decodeJson json of
- Right (LastfmResponse { recenttracks: LastfmRecentTracks { track, attr: LastfmAttr { totalPages } } }) ->
+ Right
+ ( LastfmResponse
+ { recenttracks: LastfmRecentTracks
+ { track, attr: LastfmAttr { totalPages } }
+ }
+ ) ->
let
tracks = case track of
LastfmTrackArray' ts -> ts
Left _ ->
Nothing
+-- | Convert a Last.fm track JSON value into a listen when it has a timestamp.
lastfmTrackToListen :: Json -> Maybe Listen
lastfmTrackToListen json = case decodeJson json of
- Right (LastfmTrack { name, artist: LastfmArtist { text: artistName }, album, date }) -> do
+ Right
+ ( LastfmTrack
+ { name, artist: LastfmArtist { text: artistName }, album, date }
+ ) -> do
ts <- date >>= \(LastfmDate { uts }) -> Just uts
let
releaseName = album >>= \(LastfmAlbum { text }) -> text
- releaseMbid = album >>= \(LastfmAlbum { mbid }) -> if mbid == "" then Nothing else Just mbid
+ releaseMbid = album >>= \(LastfmAlbum { mbid }) ->
+ if mbid == "" then Nothing else Just mbid
pure $ Listen
{ listenedAt: Just ts
, trackMetadata: TrackMetadata
when (n > 0) $ liftEffect $ Metrics.incSyncScrobbles slug source n
liftEffect $ Metrics.setSyncLastSuccess slug source
+-- | Perform one ListenBrainz synchronization pass.
lbSync :: Connection -> String -> String -> AVar Unit -> Aff Unit
lbSync conn username slug writeLock = void do
Log.info $ "Starting ListenBrainz sync for " <> username
- result <- try $ fetchListenBrainzUrl (listenBrainzUrl username <> "?count=100")
+ result <- try $ fetchListenBrainzUrl
+ (listenBrainzUrl username <> "?count=100")
case result of
Left err -> do
Log.error $ "Sync fetch error: " <> message err
added = syncResult.added
minTs = syncResult.minTs
hitCount = syncResult.hitCount
- Log.info $ "ListenBrainz batch 1: added " <> show added <> ", " <> show hitCount <> " already present."
+ Log.info $ "ListenBrainz batch 1: added " <> show added <> ", "
+ <> show hitCount
+ <> " already present."
let allExist = hitCount == length listens && not (null listens)
if allExist || null listens then do
- when (added > 0) $ Log.info $ "ListenBrainz sync complete. Added " <> show added <> " new scrobbles."
+ when (added > 0) $ Log.info $ "ListenBrainz sync complete. Added "
+ <> show added
+ <> " new scrobbles."
recordSyncSuccess slug "listenbrainz" added
else do
total <- paginateUntilDone 2 minTs added
- Log.info $ "ListenBrainz sync complete. Added " <> show total <> " new scrobbles."
+ Log.info $ "ListenBrainz sync complete. Added " <> show total <>
+ " new scrobbles."
recordSyncSuccess slug "listenbrainz" total
where
paginateUntilDone batchNum minTs acc = case minTs of
Nothing ->
pure acc
Just ts -> do
- Log.info $ "Fetching ListenBrainz batch " <> show batchNum <> " (before " <> show ts <> ")..."
- result <- try $ fetchListenBrainzUrl (listenBrainzUrl username <> "?count=100&max_ts=" <> show ts)
+ Log.info $ "Fetching ListenBrainz batch " <> show batchNum <> " (before "
+ <> show ts
+ <> ")..."
+ result <- try $ fetchListenBrainzUrl
+ (listenBrainzUrl username <> "?count=100&max_ts=" <> show ts)
case result of
Left err -> do
Log.error $ "Sync fetch error: " <> message err
Log.error $ "Sync parse error: " <> show err
pure acc
Right (ListenBrainzResponse { payload: Payload { listens } }) -> do
- syncResult <- withTransaction conn writeLock (processListens listens)
+ syncResult <- withTransaction conn writeLock
+ (processListens listens)
let
added = syncResult.added
newMinTs = syncResult.minTs
hitCount = syncResult.hitCount
- Log.info $ "ListenBrainz batch " <> show batchNum <> ": added " <> show added <> ", " <> show hitCount <> " already present."
+ Log.info $ "ListenBrainz batch " <> show batchNum <> ": added "
+ <> show added
+ <> ", "
+ <> show hitCount
+ <> " already present."
let allExist = hitCount == length listens && not (null listens)
if allExist || null listens then
pure (acc + added)
processListens listens = processTracks conn listens true
+-- | Run ListenBrainz synchronization every minute.
lbSyncLoop :: Connection -> String -> String -> AVar Unit -> Aff Unit
lbSyncLoop conn username slug writeLock = forever do
delay (Milliseconds 60000.0)
lbSync conn username slug writeLock
+-- | Perform one Last.fm synchronization and optional history backfill.
lfSync :: Connection -> String -> String -> String -> AVar Unit -> Aff Unit
lfSync conn apiKey lfmUser slug writeLock = do
void performLastfmSync
let
added = result.added
hitCount = result.hitCount
- Log.info $ "Last.fm page 1/" <> show totalPages <> ": added " <> show added <> ", " <> show hitCount <> " already present."
+ Log.info $ "Last.fm page 1/" <> show totalPages <> ": added "
+ <> show added
+ <> ", "
+ <> show hitCount
+ <> " already present."
let
validTracks = mapMaybe lastfmTrackToListen tracks
allExist = hitCount == length validTracks && not (null validTracks)
if allExist || totalPages <= 1 then do
- when (added > 0) $ Log.info $ "Last.fm sync complete. Added " <> show added <> " new scrobbles."
+ when (added > 0) $ Log.info $ "Last.fm sync complete. Added "
+ <> show added
+ <> " new scrobbles."
recordSyncSuccess slug "lastfm" added
else do
total <- paginateLastfmUntilDone 2 totalPages Nothing added
- Log.info $ "Last.fm sync complete. Added " <> show total <> " new scrobbles."
+ Log.info $ "Last.fm sync complete. Added " <> show total <>
+ " new scrobbles."
recordSyncSuccess slug "lastfm" total
paginateLastfmUntilDone page totalPages mTo acc
| page > totalPages = pure acc
| otherwise = do
- Log.info $ "Fetching Last.fm page " <> show page <> "/" <> show totalPages <> "..."
+ Log.info $ "Fetching Last.fm page " <> show page <> "/"
+ <> show totalPages
+ <> "..."
res <- try $ fetchLastfmPage apiKey lfmUser page mTo
case res of
Left err -> do
Log.error $ "Last.fm sync fetch error: " <> message err
pure acc
Right { tracks } -> do
- result <- withTransaction conn writeLock (processLastfmTracks tracks)
+ result <- withTransaction conn writeLock
+ (processLastfmTracks tracks)
let
added = result.added
hitCount = result.hitCount
- Log.info $ "Last.fm page" <> show page <> "/" <> show totalPages <> ": added " <> show added <> ", " <> show hitCount <> " already present."
+ Log.info $ "Last.fm page" <> show page <> "/" <> show totalPages
+ <> ": added "
+ <> show added
+ <> ", "
+ <> show hitCount
+ <> " already present."
let
validTracks = mapMaybe lastfmTrackToListen tracks
- allExist = hitCount == length validTracks && not (null validTracks)
+ allExist = hitCount == length validTracks && not
+ (null validTracks)
if allExist || null tracks then pure (acc + added)
else paginateLastfmUntilDone (page + 1) totalPages mTo (acc + added)
performLastfmBackfill = do
mOldest <- getOldestTs conn
for_ mOldest \oldestTs -> do
- Log.info $ "Checking for Last.fm history before " <> show oldestTs <> "..."
+ Log.info $ "Checking for Last.fm history before " <> show oldestTs <>
+ "..."
res <- try $ fetchLastfmPage apiKey lfmUser 1 (Just (oldestTs - 1))
case res of
Left err ->
if null tracks then
Log.info "No older Last.fm history found."
else do
- Log.info $ "Backfilling " <> show totalPages <> " pages of Last.fm history before " <> show oldestTs
- result <- withTransaction conn writeLock (processLastfmTracks tracks)
+ Log.info $ "Backfilling " <> show totalPages
+ <> " pages of Last.fm history before "
+ <> show oldestTs
+ result <- withTransaction conn writeLock
+ (processLastfmTracks tracks)
let
added = result.added
hitCount = result.hitCount
- Log.info $ "Last.fm backfill page 1/" <> show totalPages <> ": added " <> show added <> ", " <> show hitCount <> " already present."
- total <- paginateLastfmUntilDone 2 totalPages (Just (oldestTs - 1)) added
- Log.info $ "Last.fm backfill complete. Added " <> show total <> " older scrobbles."
+ Log.info $ "Last.fm backfill page 1/" <> show totalPages
+ <> ": added "
+ <> show added
+ <> ", "
+ <> show hitCount
+ <> " already present."
+ total <- paginateLastfmUntilDone 2 totalPages (Just (oldestTs - 1))
+ added
+ Log.info $ "Last.fm backfill complete. Added " <> show total <>
+ " older scrobbles."
- processLastfmTracks tracks = processTracks conn (mapMaybe lastfmTrackToListen tracks) false
+ processLastfmTracks tracks = processTracks conn
+ (mapMaybe lastfmTrackToListen tracks)
+ false
+-- | Run Last.fm synchronization every minute.
lfSyncLoop :: Connection -> String -> String -> String -> AVar Unit -> Aff Unit
lfSyncLoop conn apiKey lfmUser slug writeLock = forever do
delay (Milliseconds 60000.0)
blob - 20829b078fcf2deb6b108dbcdad2cdf4ff15a6fb
blob + 93438b6a136a4f1b25a58e315edbb97bec929aef
--- src/Templates.purs
+++ src/Templates.purs
-module Templates where
+module Templates (indexHtml) where
import Prelude
+
import Data.String.Common (joinWith)
-indexHtml :: Boolean -> String -> Array { slug :: String, name :: String } -> String
+-- | Render the HTML shell and embed the initial frontend configuration.
+indexHtml
+ :: Boolean -> String -> Array { slug :: String, name :: String } -> String
indexHtml registrationEnabled userSlug allUsers =
let
- encodeUser { slug, name } = "{\"slug\":\"" <> slug <> "\",\"name\":\"" <> name <> "\"}"
+ encodeUser { slug, name } = "{\"slug\":\"" <> slug <> "\",\"name\":\""
+ <> name
+ <> "\"}"
usersJson = "[" <> joinWith "," (map encodeUser allUsers) <> "]"
registrationEnabledJson = if registrationEnabled then "true" else "false"
in
blob - 84734a4f36cdae6970a2e033b6c3641eaf5a4bf2
blob + 4ba2528c47e2499b96a27515c2d5af8c853a08d4
--- src/Types.purs
+++ src/Types.purs
import Prelude
-import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, encodeJson, (.:), (.:?), (:=), (~>))
+import Data.Argonaut
+ ( class DecodeJson
+ , class EncodeJson
+ , decodeJson
+ , encodeJson
+ , (.:)
+ , (.:?)
+ , (:=)
+ , (~>)
+ )
+import Data.Argonaut.Core (Json, jsonEmptyObject, toArray, toNumber, toString)
import Data.Argonaut.Decode.Error (JsonDecodeError(..))
import Data.Either (Either(..))
-import Data.Argonaut.Core (Json, toArray, jsonEmptyObject, toNumber, toString)
-import Data.Int (fromString, fromNumber)
-import Data.Maybe (Maybe(..), fromMaybe)
import Data.Generic.Rep (class Generic)
+import Data.Int (fromNumber, fromString)
+import Data.Maybe (Maybe(..), fromMaybe)
import Data.Show.Generic (genericShow)
+-- | A ListenBrainz submission request body.
newtype ListenBrainzSubmitPayload = ListenBrainzSubmitPayload
{ listenType :: String
, payload :: Array ListenBrainzSubmitListen
}
derive instance eqListenBrainzSubmitPayload :: Eq ListenBrainzSubmitPayload
-derive instance genericListenBrainzSubmitPayload :: Generic ListenBrainzSubmitPayload _
+derive instance genericListenBrainzSubmitPayload ::
+ Generic ListenBrainzSubmitPayload _
+
instance showListenBrainzSubmitPayload :: Show ListenBrainzSubmitPayload where
show = genericShow
payload <- obj .: "payload"
pure $ ListenBrainzSubmitPayload { listenType, payload }
+-- | One listen submitted to ListenBrainz.
newtype ListenBrainzSubmitListen = ListenBrainzSubmitListen
{ listenedAt :: Maybe Int
, trackMetadata :: ListenBrainzSubmitTrackMetadata
}
derive instance eqListenBrainzSubmitListen :: Eq ListenBrainzSubmitListen
-derive instance genericListenBrainzSubmitListen :: Generic ListenBrainzSubmitListen _
+derive instance genericListenBrainzSubmitListen ::
+ Generic ListenBrainzSubmitListen _
+
instance showListenBrainzSubmitListen :: Show ListenBrainzSubmitListen where
show = genericShow
trackMetadata <- obj .: "track_metadata"
pure $ ListenBrainzSubmitListen { listenedAt, trackMetadata }
+-- | Track metadata nested in a ListenBrainz submission.
newtype ListenBrainzSubmitTrackMetadata = ListenBrainzSubmitTrackMetadata
{ trackName :: String
, artistName :: String
, additionalInfo :: Maybe ListenBrainzAdditionalInfo
}
-derive instance eqListenBrainzSubmitTrackMetadata :: Eq ListenBrainzSubmitTrackMetadata
-derive instance genericListenBrainzSubmitTrackMetadata :: Generic ListenBrainzSubmitTrackMetadata _
-instance showListenBrainzSubmitTrackMetadata :: Show ListenBrainzSubmitTrackMetadata where
+derive instance eqListenBrainzSubmitTrackMetadata ::
+ Eq ListenBrainzSubmitTrackMetadata
+
+derive instance genericListenBrainzSubmitTrackMetadata ::
+ Generic ListenBrainzSubmitTrackMetadata _
+
+instance showListenBrainzSubmitTrackMetadata ::
+ Show ListenBrainzSubmitTrackMetadata where
show = genericShow
instance DecodeJson ListenBrainzSubmitTrackMetadata where
artistName <- obj .: "artist_name"
releaseName <- obj .:? "release_name"
additionalInfo <- obj .:? "additional_info"
- pure $ ListenBrainzSubmitTrackMetadata { trackName, artistName, releaseName, additionalInfo }
+ pure $ ListenBrainzSubmitTrackMetadata
+ { trackName, artistName, releaseName, additionalInfo }
+-- | Optional provider identifiers attached to submitted track metadata.
newtype ListenBrainzAdditionalInfo = ListenBrainzAdditionalInfo
{ releaseMbid :: Maybe String
, artistMbids :: Maybe (Array String)
}
derive instance eqListenBrainzAdditionalInfo :: Eq ListenBrainzAdditionalInfo
-derive instance genericListenBrainzAdditionalInfo :: Generic ListenBrainzAdditionalInfo _
+derive instance genericListenBrainzAdditionalInfo ::
+ Generic ListenBrainzAdditionalInfo _
+
instance showListenBrainzAdditionalInfo :: Show ListenBrainzAdditionalInfo where
show = genericShow
releaseMbid <- obj .:? "release_mbid"
artistMbids <- obj .:? "artist_mbids"
recordingMbid <- obj .:? "recording_mbid"
- pure $ ListenBrainzAdditionalInfo { releaseMbid, artistMbids, recordingMbid }
+ pure $ ListenBrainzAdditionalInfo
+ { releaseMbid, artistMbids, recordingMbid }
+-- | A paged ListenBrainz listen response.
newtype ListenBrainzResponse = ListenBrainzResponse
{ payload :: Payload
}
"payload" := encodeJson payload
~> jsonEmptyObject
+-- | The listen array contained in a ListenBrainz response.
newtype Payload = Payload
{ listens :: Array Listen
}
"listens" := encodeJson listens
~> jsonEmptyObject
+-- | Corpus's normalized representation of a scrobble.
newtype Listen = Listen
{ trackMetadata :: TrackMetadata
, listenedAt :: Maybe Int
~> "listened_at" := encodeJson listenedAt
~> jsonEmptyObject
+-- | Metadata for a listen returned by ListenBrainz.
newtype TrackMetadata = TrackMetadata
{ trackName :: Maybe String
, artistName :: Maybe String
mbidMapping <- obj .:? "mbid_mapping"
genre <- obj .:? "genre"
label <- obj .:? "label"
- pure $ TrackMetadata { trackName, artistName, releaseName, mbidMapping, genre, label }
+ pure $ TrackMetadata
+ { trackName, artistName, releaseName, mbidMapping, genre, label }
instance EncodeJson TrackMetadata where
- encodeJson (TrackMetadata { trackName, artistName, releaseName, mbidMapping, genre, label }) =
+ encodeJson
+ ( TrackMetadata
+ { trackName, artistName, releaseName, mbidMapping, genre, label }
+ ) =
"track_name" := encodeJson trackName
~> "artist_name" := encodeJson artistName
~> "release_name" := encodeJson releaseName
~> "label" := encodeJson label
~> jsonEmptyObject
+-- | MusicBrainz identifiers associated with a track.
newtype MbidMapping = MbidMapping
{ releaseMbid :: Maybe String
, caaReleaseMbid :: Maybe String
-- Last.fm API types
+-- | Pagination attributes from a Last.fm recent-tracks response.
newtype LastfmAttr = LastfmAttr
{ totalPages :: Int
}
Just n -> pure $ LastfmAttr { totalPages: n }
Nothing -> Left $ TypeMismatch "Invalid totalPages"
+-- | A Last.fm track collection represented as an array.
newtype LastfmTrackArray = LastfmTrackArray (Array Json)
+-- | A Last.fm track collection represented as a single JSON object.
newtype LastfmTrackSingle = LastfmTrackSingle Json
+-- | The two shapes Last.fm uses for recent-track results.
data LastfmTracks = LastfmTrackArray' (Array Json) | LastfmTrackSingle' Json
instance showLastfmTracks :: Show LastfmTracks where
show (LastfmTrackArray' _) = "LastfmTrackArray' _"
show (LastfmTrackSingle' _) = "LastfmTrackSingle' _"
+-- | The recent-tracks object in a Last.fm API response.
newtype LastfmRecentTracks = LastfmRecentTracks
{ track :: LastfmTracks
, attr :: LastfmAttr
pure $ LastfmTrackSingle' trackJson
pure $ LastfmRecentTracks { track: tracks, attr }
+-- | A decoded Last.fm recent-tracks response.
newtype LastfmResponse = LastfmResponse
{ recenttracks :: LastfmRecentTracks
}
recenttracks <- obj .: "recenttracks"
pure $ LastfmResponse { recenttracks }
+-- | The artist field returned by Last.fm.
newtype LastfmArtist = LastfmArtist { text :: String }
derive instance genericLastfmArtist :: Generic LastfmArtist _
text <- obj .: "#text"
pure $ LastfmArtist { text }
+-- | The album field returned by Last.fm.
newtype LastfmAlbum = LastfmAlbum
{ text :: Maybe String
, mbid :: String
mbid <- fromMaybe "" <$> obj .:? "mbid"
pure $ LastfmAlbum { text, mbid }
+-- | A Last.fm Unix timestamp wrapper.
newtype LastfmDate = LastfmDate { uts :: Int }
derive instance genericLastfmDate :: Generic LastfmDate _
Just n -> pure $ LastfmDate { uts: n }
Nothing -> Left $ TypeMismatch $ "Invalid uts: " <> utsStr
+-- | One track in a Last.fm recent-tracks response.
newtype LastfmTrack = LastfmTrack
{ name :: String
, artist :: LastfmArtist
date <- obj .:? "date"
pure $ LastfmTrack { name, artist, album, date }
+-- | One named aggregate in the statistics response.
newtype StatsEntry = StatsEntry
{ name :: String
, count :: Int
~> "count" := encodeJson count
~> jsonEmptyObject
+-- | Aggregated listening statistics returned by the API.
newtype Stats = Stats
{ totalScrobbles :: Int
, genres :: Array StatsEntry
blob - cfabe57c38ef9cc81526584ec02d3955c098cf55
blob + 7e729a685b47ead8200084b63b8b70cb41a417a2
--- test/Main.purs
+++ test/Main.purs
import Prelude
+import Cover
+ ( cacheJobKey
+ , coverSources
+ , finishCacheFill
+ , sanitizeKey
+ , tryStartCacheFill
+ )
import Data.Argonaut (decodeJson, encodeJson, parseJson)
+import Data.Argonaut.Core (Json, toBoolean, toNumber, toString)
import Data.Array (length)
import Data.Either (Either(..), isRight)
import Data.Maybe (Maybe(..))
+import Data.String.Regex (parseFlags, regex)
+import Data.Time.Duration (Milliseconds(..))
+import Db
+ ( FilterField(..)
+ , checkExists
+ , connect
+ , dbBaseName
+ , fromString
+ , getArtistReleasesByMbids
+ , getEmptyGenreMbids
+ , getOldestTs
+ , getOrCreateToken
+ , getScrobbles
+ , getStats
+ , getTokenUser
+ , getUnenrichedMbids
+ , initDb
+ , initReleaseMetadata
+ , touchGenreCheckedAt
+ , upsertReleaseMetadata
+ , upsertScrobble
+ )
import Effect (Effect)
import Effect.Aff (delay, try)
import Effect.Aff.AVar as Avar
import Effect.Class (liftEffect)
import Effect.Exception (message)
-import Data.Time.Duration (Milliseconds(..))
+import Foreign.Object as Object
+import Http (withTimeout)
+import Main
+ ( findUserByToken
+ , parseAuthToken
+ , parseBearer
+ , sanitizeDate
+ , submitListenToListen
+ , validateTokenJson
+ )
+import Registrations
+ ( getById
+ , initRegistrations
+ , insertRegistration
+ , isReservedSlug
+ , listByStatus
+ , setStatus
+ , slugTaken
+ , validSlugFormat
+ )
+import Sync (lastfmTrackToListen, listenBrainzUrl, parseLastfmResponse)
import Test.Spec (describe, it)
-import Test.Spec.Assertions (shouldEqual, fail)
-import Data.String.Regex (regex, parseFlags)
+import Test.Spec.Assertions (fail, shouldEqual)
import Test.Spec.Reporter.Console (consoleReporter)
import Test.Spec.Runner.Node (runSpecAndExitProcess)
-import Types (Listen(..), ListenBrainzResponse(..), MbidMapping(..), Payload(..), Stats(..), StatsEntry(..), TrackMetadata(..), ListenBrainzSubmitPayload(..), ListenBrainzSubmitListen(..), ListenBrainzSubmitTrackMetadata(..), ListenBrainzAdditionalInfo(..))
-import Db (FilterField(..), connect, initDb, checkExists, upsertScrobble, getScrobbles, initReleaseMetadata, upsertReleaseMetadata, getStats, dbBaseName, getOldestTs, getUnenrichedMbids, getEmptyGenreMbids, getArtistReleasesByMbids, touchGenreCheckedAt, getOrCreateToken, getTokenUser, fromString)
-import Data.Argonaut.Core (Json, toBoolean, toNumber, toString)
-import Foreign.Object as Object
-import Main (submitListenToListen, findUserByToken, sanitizeDate, parseAuthToken, parseBearer, validateTokenJson)
-import Registrations (getById, initRegistrations, insertRegistration, isReservedSlug, listByStatus, setStatus, slugTaken, validSlugFormat)
-import Cover (sanitizeKey, cacheJobKey, coverSources, finishCacheFill, tryStartCacheFill)
-import Sync (listenBrainzUrl, lastfmTrackToListen, parseLastfmResponse)
-import Http (withTimeout)
+import Types
+ ( Listen(..)
+ , ListenBrainzAdditionalInfo(..)
+ , ListenBrainzResponse(..)
+ , ListenBrainzSubmitListen(..)
+ , ListenBrainzSubmitPayload(..)
+ , ListenBrainzSubmitTrackMetadata(..)
+ , MbidMapping(..)
+ , Payload(..)
+ , Stats(..)
+ , StatsEntry(..)
+ , TrackMetadata(..)
+ )
main :: Effect Unit
main = runSpecAndExitProcess [ consoleReporter ] do
describe "Corpus Main Utils" do
it "cancels operations that exceed their fetch timeout" do
- result <- try $ withTimeout (Milliseconds 1.0) "test request" (delay (Milliseconds 20.0))
+ result <- try $ withTimeout (Milliseconds 1.0) "test request"
+ (delay (Milliseconds 20.0))
case result of
Left err -> message err `shouldEqual` "test request timed out"
Right _ -> fail "Expected timeout"
it "should build ListenBrainz URLs correctly" do
- listenBrainzUrl "user1" `shouldEqual` "https://api.listenbrainz.org/1/user/user1/listens"
+ listenBrainzUrl "user1" `shouldEqual`
+ "https://api.listenbrainz.org/1/user/user1/listens"
it "regex patterns should compile successfully" do
let re1 = regex "[^a-z0-9.-]" (parseFlags "gi")
sanitizeKey "UPPER lower" `shouldEqual` "UPPER_lower"
it "scopes concurrent cover-cache jobs to their S3 bucket and key" do
- cacheJobKey "covers-a" "covers/caa/release.avif" `shouldEqual` "covers-a:covers/caa/release.avif"
- cacheJobKey "covers-b" "covers/caa/release.avif" `shouldEqual` "covers-b:covers/caa/release.avif"
+ cacheJobKey "covers-a" "covers/caa/release.avif" `shouldEqual`
+ "covers-a:covers/caa/release.avif"
+ cacheJobKey "covers-b" "covers/caa/release.avif" `shouldEqual`
+ "covers-b:covers/caa/release.avif"
- it "coalesces duplicate cover-cache jobs and releases their key on completion" do
- let key = cacheJobKey "test-bucket" "covers/caa/release.avif"
- first <- liftEffect $ tryStartCacheFill key
- second <- liftEffect $ tryStartCacheFill key
- liftEffect $ finishCacheFill key
- third <- liftEffect $ tryStartCacheFill key
- liftEffect $ finishCacheFill key
- first `shouldEqual` true
- second `shouldEqual` false
- third `shouldEqual` true
+ it
+ "coalesces duplicate cover-cache jobs and releases their key on completion"
+ do
+ let key = cacheJobKey "test-bucket" "covers/caa/release.avif"
+ first <- liftEffect $ tryStartCacheFill key
+ second <- liftEffect $ tryStartCacheFill key
+ liftEffect $ finishCacheFill key
+ third <- liftEffect $ tryStartCacheFill key
+ liftEffect $ finishCacheFill key
+ first `shouldEqual` true
+ second `shouldEqual` false
+ third `shouldEqual` true
it "limits background cover-cache fills across distinct keys" do
one <- liftEffect $ tryStartCacheFill "capacity-1"
}
it "prefers CAA and uses source-specific cache keys" do
- let sources = coverSources "release/id" "The Artist" "The Release" coverConfig
+ let
+ sources = coverSources "release/id" "The Artist" "The Release"
+ coverConfig
map _.name sources `shouldEqual` [ "caa", "discogs", "lastfm" ]
map _.s3Key sources `shouldEqual`
[ "covers/caa/release_id.avif"
listenType `shouldEqual` "single"
length payload `shouldEqual` 1
case payload of
- [ ListenBrainzSubmitListen { listenedAt, trackMetadata: ListenBrainzSubmitTrackMetadata m } ] -> do
+ [ ListenBrainzSubmitListen
+ { listenedAt, trackMetadata: ListenBrainzSubmitTrackMetadata m }
+ ] -> do
listenedAt `shouldEqual` Just 123456789
m.trackName `shouldEqual` "Song Name"
m.artistName `shouldEqual` "Artist Name"
m.trackName `shouldEqual` Just "Song Name"
m.artistName `shouldEqual` Just "Artist Name"
m.releaseName `shouldEqual` Just "Album Name"
- m.mbidMapping `shouldEqual` Just (MbidMapping { releaseMbid: Just "rel-mbid", caaReleaseMbid: Just "rel-mbid" })
+ m.mbidMapping `shouldEqual` Just
+ ( MbidMapping
+ { releaseMbid: Just "rel-mbid"
+ , caaReleaseMbid: Just "rel-mbid"
+ }
+ )
Nothing -> do
fail "Conversion failed"
case result of
Right obj -> do
(Object.lookup "valid" obj >>= toBoolean) `shouldEqual` Just true
- (Object.lookup "user_name" obj >>= toString) `shouldEqual` Just "User One"
+ (Object.lookup "user_name" obj >>= toString) `shouldEqual` Just
+ "User One"
(Object.lookup "code" obj >>= toNumber) `shouldEqual` Just 200.0
Left _ ->
fail "validateTokenJson did not produce valid JSON"
lock1 <- Avar.new unit
lock2 <- Avar.new unit
let
- ctx1 = { conn: conn1, writeLock: lock1, config: dummyConfig, slug: "user1", displayName: "User 1", isRegistered: false, initialSyncFibers: [], enrichMetadataFiber: Nothing, backupFiber: Nothing, syncFibers: [] }
- ctx2 = { conn: conn2, writeLock: lock2, config: dummyConfig, slug: "user2", displayName: "User 2", isRegistered: false, initialSyncFibers: [], enrichMetadataFiber: Nothing, backupFiber: Nothing, syncFibers: [] }
+ ctx1 =
+ { conn: conn1
+ , writeLock: lock1
+ , config: dummyConfig
+ , slug: "user1"
+ , displayName: "User 1"
+ , isRegistered: false
+ , initialSyncFibers: []
+ , enrichMetadataFiber: Nothing
+ , backupFiber: Nothing
+ , syncFibers: []
+ }
+ ctx2 =
+ { conn: conn2
+ , writeLock: lock2
+ , config: dummyConfig
+ , slug: "user2"
+ , displayName: "User 2"
+ , isRegistered: false
+ , initialSyncFibers: []
+ , enrichMetadataFiber: Nothing
+ , backupFiber: Nothing
+ , syncFibers: []
+ }
contexts = [ ctx1, ctx2 ]
res1 <- findUserByToken contexts token1
describe "Corpus Types" do
describe "MbidMapping Codecs" do
it "should roundtrip MbidMapping" do
- let mbid = MbidMapping { releaseMbid: Just "release-123", caaReleaseMbid: Just "caa-456" }
+ let
+ mbid = MbidMapping
+ { releaseMbid: Just "release-123", caaReleaseMbid: Just "caa-456" }
decodeJson (encodeJson mbid) `shouldEqual` Right mbid
it "should decode MbidMapping with missing fields" do
let jsonStr = "{\"release_mbid\": \"abc\"}"
- let expected = MbidMapping { releaseMbid: Just "abc", caaReleaseMbid: Nothing }
+ let
+ expected = MbidMapping
+ { releaseMbid: Just "abc", caaReleaseMbid: Nothing }
(parseJson jsonStr >>= decodeJson) `shouldEqual` Right expected
describe "TrackMetadata Codecs" do
{ trackName: Just "Song"
, artistName: Just "Artist"
, releaseName: Just "Album"
- , mbidMapping: Just (MbidMapping { releaseMbid: Just "rb", caaReleaseMbid: Nothing })
+ , mbidMapping: Just
+ ( MbidMapping
+ { releaseMbid: Just "rb", caaReleaseMbid: Nothing }
+ )
, genre: Just "Rock"
, label: Nothing
}
{ trackName: Just "Song"
, artistName: Just "Artist"
, releaseName: Just "Album"
- , mbidMapping: Just (MbidMapping { releaseMbid: Just "rb1", caaReleaseMbid: Nothing })
+ , mbidMapping: Just
+ ( MbidMapping
+ { releaseMbid: Just "rb1", caaReleaseMbid: Nothing }
+ )
, genre: Nothing
, label: Nothing
}
listensWithGenre <- getScrobbles conn 10 0 Nothing Nothing
case listensWithGenre of
- [ Listen { trackMetadata: TrackMetadata m } ] -> m.genre `shouldEqual` Just "Rock"
+ [ Listen { trackMetadata: TrackMetadata m } ] -> m.genre `shouldEqual`
+ Just "Rock"
_ -> fail "Expected 1 listen"
upsertScrobble conn $ Listen
length s.artists `shouldEqual` 1
length s.tracks `shouldEqual` 2
- Stats customRangeStats <- getStats conn Nothing (Just "1970-01-01") (Just "1970-01-01") Nothing
+ Stats customRangeStats <- getStats conn Nothing (Just "1970-01-01")
+ (Just "1970-01-01")
+ Nothing
customRangeStats.totalScrobbles `shouldEqual` 2
-- Test Filtering (as mentioned in architecture.md)
- listensFiltered <- getScrobbles conn 10 0 (Just { field: FilterGenre, value: "Rock" }) Nothing
+ listensFiltered <- getScrobbles conn 10 0
+ (Just { field: FilterGenre, value: "Rock" })
+ Nothing
length listensFiltered `shouldEqual` 1
- listensEmpty <- getScrobbles conn 10 0 (Just { field: FilterGenre, value: "Jazz" }) Nothing
+ listensEmpty <- getScrobbles conn 10 0
+ (Just { field: FilterGenre, value: "Jazz" })
+ Nothing
length listensEmpty `shouldEqual` 0
it "upsertScrobble is idempotent" do
{ trackName: Just "Song"
, artistName: Just "Artist"
, releaseName: Just "Album"
- , mbidMapping: Just (MbidMapping { releaseMbid: Just "mb1", caaReleaseMbid: Nothing })
+ , mbidMapping: Just
+ ( MbidMapping
+ { releaseMbid: Just "mb1", caaReleaseMbid: Nothing }
+ )
, genre: Nothing
, label: Nothing
}
}
upsertScrobble conn (mkListen 1 "Alpha")
upsertScrobble conn (mkListen 2 "Beta")
- listens <- getScrobbles conn 10 0 (Just { field: FilterArtist, value: "Alpha" }) Nothing
+ listens <- getScrobbles conn 10 0
+ (Just { field: FilterArtist, value: "Alpha" })
+ Nothing
length listens `shouldEqual` 1
- listensNone <- getScrobbles conn 10 0 (Just { field: FilterArtist, value: "Gamma" }) Nothing
+ listensNone <- getScrobbles conn 10 0
+ (Just { field: FilterArtist, value: "Gamma" })
+ Nothing
length listensNone `shouldEqual` 0
it "filters by album" do
}
upsertScrobble conn (mkListen "Artist" "Album A")
upsertScrobble conn (mkListen "Artist" "Album B")
- listens <- getScrobbles conn 10 0 (Just { field: FilterAlbum, value: "Album A" }) Nothing
+ listens <- getScrobbles conn 10 0
+ (Just { field: FilterAlbum, value: "Album A" })
+ Nothing
length listens `shouldEqual` 1
- listensNone <- getScrobbles conn 10 0 (Just { field: FilterAlbum, value: "Album C" }) Nothing
+ listensNone <- getScrobbles conn 10 0
+ (Just { field: FilterAlbum, value: "Album C" })
+ Nothing
length listensNone `shouldEqual` 0
it "filters by label" do
{ trackName: Just "Song"
, artistName: Just "Artist"
, releaseName: Just "Album"
- , mbidMapping: Just (MbidMapping { releaseMbid: Just "mb-label", caaReleaseMbid: Nothing })
+ , mbidMapping: Just
+ ( MbidMapping
+ { releaseMbid: Just "mb-label"
+ , caaReleaseMbid: Nothing
+ }
+ )
, genre: Nothing
, label: Nothing
}
}
)
upsertReleaseMetadata conn "mb-label" Nothing (Just "Warp") (Just 2000)
- listens <- getScrobbles conn 10 0 (Just { field: FilterLabel, value: "Warp" }) Nothing
+ listens <- getScrobbles conn 10 0
+ (Just { field: FilterLabel, value: "Warp" })
+ Nothing
length listens `shouldEqual` 1
- listensNone <- getScrobbles conn 10 0 (Just { field: FilterLabel, value: "Columbia" }) Nothing
+ listensNone <- getScrobbles conn 10 0
+ (Just { field: FilterLabel, value: "Columbia" })
+ Nothing
length listensNone `shouldEqual` 0
it "filters by year" do
{ trackName: Just "Song"
, artistName: Just "Artist"
, releaseName: Just "Album"
- , mbidMapping: Just (MbidMapping { releaseMbid: Just "mb-year", caaReleaseMbid: Nothing })
+ , mbidMapping: Just
+ ( MbidMapping
+ { releaseMbid: Just "mb-year"
+ , caaReleaseMbid: Nothing
+ }
+ )
, genre: Nothing
, label: Nothing
}
}
)
upsertReleaseMetadata conn "mb-year" Nothing Nothing (Just 1994)
- listens <- getScrobbles conn 10 0 (Just { field: FilterYear, value: "1994" }) Nothing
+ listens <- getScrobbles conn 10 0
+ (Just { field: FilterYear, value: "1994" })
+ Nothing
length listens `shouldEqual` 1
- listensNone <- getScrobbles conn 10 0 (Just { field: FilterYear, value: "1999" }) Nothing
+ listensNone <- getScrobbles conn 10 0
+ (Just { field: FilterYear, value: "1999" })
+ Nothing
length listensNone `shouldEqual` 0
- it "filters by track and searches across track, artist, release, and label" do
- conn <- connect ":memory:"
- initDb conn
- initReleaseMetadata conn
- upsertScrobble conn
- ( Listen
- { listenedAt: Just 300
- , trackMetadata: TrackMetadata
- { trackName: Just "Neon Skyline"
- , artistName: Just "Andy Shauf"
- , releaseName: Just "The Neon Skyline"
- , mbidMapping: Just (MbidMapping { releaseMbid: Just "search-mbid", caaReleaseMbid: Nothing })
- , genre: Nothing
- , label: Nothing
- }
- }
- )
- upsertReleaseMetadata conn "search-mbid" Nothing (Just "Anti-") (Just 2020)
- exact <- getScrobbles conn 10 0 (Just { field: FilterTrack, value: "Neon Skyline" }) Nothing
- byArtist <- getScrobbles conn 10 0 Nothing (Just "andy")
- byRelease <- getScrobbles conn 10 0 Nothing (Just "the neon")
- byLabel <- getScrobbles conn 10 0 Nothing (Just "anti-")
- length exact `shouldEqual` 1
- length byArtist `shouldEqual` 1
- length byRelease `shouldEqual` 1
- length byLabel `shouldEqual` 1
+ it
+ "filters by track and searches across track, artist, release, and label"
+ do
+ conn <- connect ":memory:"
+ initDb conn
+ initReleaseMetadata conn
+ upsertScrobble conn
+ ( Listen
+ { listenedAt: Just 300
+ , trackMetadata: TrackMetadata
+ { trackName: Just "Neon Skyline"
+ , artistName: Just "Andy Shauf"
+ , releaseName: Just "The Neon Skyline"
+ , mbidMapping: Just
+ ( MbidMapping
+ { releaseMbid: Just "search-mbid"
+ , caaReleaseMbid: Nothing
+ }
+ )
+ , genre: Nothing
+ , label: Nothing
+ }
+ }
+ )
+ upsertReleaseMetadata conn "search-mbid" Nothing (Just "Anti-")
+ (Just 2020)
+ exact <- getScrobbles conn 10 0
+ (Just { field: FilterTrack, value: "Neon Skyline" })
+ Nothing
+ byArtist <- getScrobbles conn 10 0 Nothing (Just "andy")
+ byRelease <- getScrobbles conn 10 0 Nothing (Just "the neon")
+ byLabel <- getScrobbles conn 10 0 Nothing (Just "anti-")
+ length exact `shouldEqual` 1
+ length byArtist `shouldEqual` 1
+ length byRelease `shouldEqual` 1
+ length byLabel `shouldEqual` 1
describe "getOldestTs" do
let
{ trackName: Just "T"
, artistName: Just "A"
, releaseName: Just "R"
- , mbidMapping: Just (MbidMapping { releaseMbid: Just mbid, caaReleaseMbid: Nothing })
+ , mbidMapping: Just
+ ( MbidMapping
+ { releaseMbid: Just mbid, caaReleaseMbid: Nothing }
+ )
, genre: Nothing
, label: Nothing
}
initDb conn
initReleaseMetadata conn
upsertScrobble conn (listenWith 2000 "enriched")
- upsertReleaseMetadata conn "enriched" (Just "Rock") (Just "Label") (Just 2020)
+ upsertReleaseMetadata conn "enriched" (Just "Rock") (Just "Label")
+ (Just 2020)
mbids <- getUnenrichedMbids conn 10
mbids `shouldEqual` []
{ trackName: Just "T"
, artistName: Just "A"
, releaseName: Just "R"
- , mbidMapping: Just (MbidMapping { releaseMbid: Just mbid, caaReleaseMbid: Nothing })
+ , mbidMapping: Just
+ ( MbidMapping
+ { releaseMbid: Just mbid, caaReleaseMbid: Nothing }
+ )
, genre: Nothing
, label: Nothing
}
{ trackName: Just "Song"
, artistName: Just "My Artist"
, releaseName: Just "My Album"
- , mbidMapping: Just (MbidMapping { releaseMbid: Just "ar-mbid", caaReleaseMbid: Nothing })
+ , mbidMapping: Just
+ ( MbidMapping
+ { releaseMbid: Just "ar-mbid"
+ , caaReleaseMbid: Nothing
+ }
+ )
, genre: Nothing
, label: Nothing
}
}
)
result <- getArtistReleasesByMbids conn [ "ar-mbid" ]
- Object.lookup "ar-mbid" result `shouldEqual` Just { artist: "My Artist", release: "My Album" }
+ Object.lookup "ar-mbid" result `shouldEqual` Just
+ { artist: "My Artist", release: "My Album" }
describe "Corpus Backup" do
describe "dbBaseName" do
m.trackName `shouldEqual` Just "Test Track"
m.artistName `shouldEqual` Just "Test Artist"
m.releaseName `shouldEqual` Just "Test Album"
- m.mbidMapping `shouldEqual` Just (MbidMapping { releaseMbid: Just "album-mbid-123", caaReleaseMbid: Just "album-mbid-123" })
+ m.mbidMapping `shouldEqual` Just
+ ( MbidMapping
+ { releaseMbid: Just "album-mbid-123"
+ , caaReleaseMbid: Just "album-mbid-123"
+ }
+ )
it "treats empty album MBID as Nothing" do
let
Nothing ->
fail "Expected Just Listen, got Nothing"
Just (Listen { trackMetadata: TrackMetadata m }) ->
- m.mbidMapping `shouldEqual` Just (MbidMapping { releaseMbid: Nothing, caaReleaseMbid: Nothing })
+ m.mbidMapping `shouldEqual` Just
+ (MbidMapping { releaseMbid: Nothing, caaReleaseMbid: Nothing })
it "skips nowplaying tracks (no date field)" do
let
Nothing ->
fail "Expected Just Listen, got Nothing"
Just (Listen { trackMetadata: TrackMetadata m }) ->
- m.mbidMapping `shouldEqual` Just (MbidMapping { releaseMbid: Just "mbid-xyz", caaReleaseMbid: Just "mbid-xyz" })
+ m.mbidMapping `shouldEqual` Just
+ ( MbidMapping
+ { releaseMbid: Just "mbid-xyz"
+ , caaReleaseMbid: Just "mbid-xyz"
+ }
+ )
it "inserts and retrieves a Last.fm-style listen from the database" do
conn <- connect ":memory:"
