commit - 63ef4f6f40c424687fa97f144c97d2f16cb88177
commit + 7893c97ef1f7ca031f7d0a23f7cddeaec3f23452
blob - b9dc06cbe85014ef2cdefda323e04f51b58a1b07
blob + 05b6b6efa1daadfec696a4def816fbd1c3c13982
--- README.md
+++ README.md
# corpus
+
[](https://builds.sr.ht/~mtmn/corpus?)
-A self-hosted [ListenBrainz](https://listenbrainz.org) and [Last.fm](https://last.fm) frontend that stores metadata and cover images.
+A self-hosted ListenBrainz and Last.fm listening-history dashboard. Corpus stores scrobbles in DuckDB, enriches release metadata, caches cover art, and serves an Elm web interface.
-It stores scrobbles, enriches track metadata and provides an interactive [Elm](https://elm-lang.org) interface.
-
## Documentation
-- [Architecture](docs/architecture.md) — Deep dive into the system components, data flow, and FFI usage.
-- [DuckDB](docs/duckdb.md) — Schema details, analytical queries, and tools for data exploration.
+- [Architecture](docs/architecture.md) — components, routing, data flows, configuration, and operations.
+- [DuckDB](docs/duckdb.md) — schema and analytical queries.
-## Usage
+## Quick start
-This project uses [just](https://github.com/casey/just) and [Nix](https://nixos.org) for development and deployment.
+With Nix:
-### Development
-
-```bash
-# Enter the development shell
+```sh
just shell
-
-# Build
just nix build
-
-# Run the binary built by Nix
just nix run
```
-### Build
+Or build locally with pnpm:
-This project uses [pnpm](https://pnpm.io) for dependency management.
-
-```bash
-# Install dependencies
+```sh
pnpm install
pnpm spago install
-
-# Build the project
pnpm run build
-
-# Run tests
pnpm test
-
-# Build an optimized release
-pnpm run release
-
-# Run the application
pnpm spago run
```
-### Scrobbling API
+## Scrobbling API
-Corpus provides a [ListenBrainz-compatible](https://listenbrainz.readthedocs.io/en/latest) endpoint for submitting scrobbles directly. This allows you to use any scrobbler that supports custom ListenBrainz endpoints.
+Corpus accepts ListenBrainz-compatible submissions at `POST /1/submit-listens`. Send `Authorization: Token <token>` and a standard ListenBrainz payload. Clients may first validate a token with `GET /1/validate-token` using the same header.
-#### Endpoint
+Tokens are shown once when a user is created, reset, or approved through self-registration. Store them securely.
-`POST /1/submit-listens`
+## Configuration
-#### Authentication
+`users.json` defines each static user's slug, source usernames, DuckDB filename, and cover/backup settings. Shared secrets and integrations are supplied by environment variables.
-The API uses token-based authentication. A unique API token is automatically generated for each user when they first start the application. You can find your token in the server logs on startup:
+| Variable | Purpose |
+|---|---|
+| `CORPUS_USERS_FILE` | Static user configuration (default: `users.json`) |
+| `DATABASE_PATH` | Directory containing user databases |
+| `LASTFM_API_KEY`, `DISCOGS_TOKEN` | Last.fm sync and metadata/cover fallbacks |
+| `S3_BUCKET` and `AWS_*` | Cover cache and optional database backups |
+| `COSINE_API_KEY` | Similar-track lookup |
+| `PORT`, `HOST` | HTTP listener (defaults: `8000`, `127.0.0.1`) |
+| `METRICS_ENABLED` | Enable Prometheus metrics at `/metrics` |
-```text
-[INFO] User 'mtmn' token: 550e8400-e29b-41d4-a716-446655440000
-```
-
-Include the token in the `Authorization` header of your requests:
-
-```text
-Authorization: Token <your-token>
-```
-
-#### Payload Format
-
-The endpoint accepts standard ListenBrainz JSON payloads. See the [ListenBrainz API documentation](https://listenbrainz.readthedocs.io/en/latest/users/api/core.html#post--1-submit-listens) for details.
-
-### Environment variables
-
-| Variable | Default | Description |
-| :--- | :--- | :--- |
-| `CORPUS_USERS_FILE` | `users.json` | Path to the multi-user config file |
-| `DATABASE_PATH` | _(cwd)_ | Root directory for all user database files |
-| `PORT` | `8000` | HTTP port to listen on |
-| `LASTFM_API_KEY` | — | Last.fm API key (required when any user has `lastfmUser` set; also used for genre and cover art fallback) |
-| `DISCOGS_TOKEN` | — | Discogs token for cover art and genre fallback |
-| `S3_BUCKET` | — | S3 bucket name for cover art caching and backups |
-| `S3_REGION` | `us-east-1` | S3 region |
-| `AWS_ACCESS_KEY_ID` | — | S3 credentials |
-| `AWS_SECRET_ACCESS_KEY` | — | S3 credentials |
-| `AWS_ENDPOINT_URL` | — | S3-compatible endpoint (e.g. for MinIO) |
-| `AWS_S3_ADDRESSING_STYLE` | — | Set to `path` for path-style S3 URLs |
-| `COSINE_API_KEY` | — | [cosine.club](https://cosine.club) API key for similar tracks |
-| `METRICS_ENABLED` | `false` | Set to `true` to expose Prometheus metrics at `/metrics` |
-| `CORS_ORIGIN` | `*` | Value for the `Access-Control-Allow-Origin` header on `/proxy` responses (e.g. `https://mtmn.name`) |
-| `REGISTRATION_ENABLED` | `false` | Set to `true` to allow public self-registration at `/register` |
-| `ADMIN_TOKEN` | — | Secret for the admin approval page at `/admin`; when unset, all admin routes 404 |
-| `ADMIN_EMAIL` | — | Address notified by email when a new registration arrives |
-| `CORPUS_REGISTRATIONS_DB` | `registrations.db` | Shared DuckDB file holding pending/approved/denied registrations |
-| `SMTP_HOST` | — | SMTP server host for notification email (email is skipped if unset) |
-| `SMTP_PORT` | `587` | SMTP port (STARTTLS) |
-| `SMTP_USER` | — | SMTP username |
-| `SMTP_PASS` | — | SMTP password |
-| `SMTP_FROM` | — | From address for notification email |
-
-### User self-registration & admin approval
-
-When `REGISTRATION_ENABLED=true`, visitors can request an account at `/register`
-(username, name, email, and optional ListenBrainz/Last.fm usernames). Requests are
-stored as _pending_ in the shared registrations database. Set `ADMIN_TOKEN` and visit
-`/admin` to review them: enter the token (remembered in `localStorage`), then **approve**
-(provisions the user live — no restart — and emails them their API token) or **deny**
-(emails the requester). Set `ADMIN_EMAIL` + `SMTP_*` to receive/send the notifications;
-without SMTP the flow still works and the token is shown in the admin UI on approval.
-
-Approved users persist as `approved` rows in the registrations database and are
-re-loaded automatically at every startup — `users.json` is **not** modified and remains
-the manual/static import mechanism (via the `add-user` CLI). If a slug is defined in both
-`users.json` and an approved registration, the `users.json` entry wins.
-
-The `/admin` page also lists registered users under **users**, each with a **remove**
-button (two-click confirm). Removing a user stops its sync fibers, drops it from the live
-set (no restart), **deletes its database file**, and marks the registration `revoked` — so
-it stays gone across restarts and the username frees up for re-registration. Removal only
-applies to self-registered users; root and `users.json`-defined users are managed manually.
-
-### Per-user configuration
-
-| Field | Default | Description |
-| :--- | :--- | :--- |
-| `slug` | — | URL slug (`""` for root user, `"filip"` for `/u/filip`) |
-| `name` | — | Display name for the user (defaults to slug if not provided) |
-| `listenbrainzUser` | — | ListenBrainz username to sync scrobbles from |
-| `lastfmUser` | — | Last.fm username to sync scrobbles from |
-| `databaseFile` | `corpus.db` | Path to the user's DuckDB database file |
-| `coverCacheEnabled` | `true` | Enable cover art caching to S3 |
-| `backupEnabled` | `false` | Enable database backups to S3 |
-| `backupIntervalHours` | `24` | Backup frequency in hours |
+Set `REGISTRATION_ENABLED=true` to allow public registration at `/register`; `ADMIN_TOKEN` enables approval at `/admin`. See the [architecture guide](docs/architecture.md#configuration-reference) for every setting and the full registration workflow.
blob - 0b3a5e435a2641351dcd83692df85487c2cab676
blob + 46d03c0e4bc484e0e32a08b23b5bd4bb28602c79
--- docs/architecture.md
+++ docs/architecture.md
- **ListenBrainz Sync**: A background process that polls the ListenBrainz API every 60 seconds to fetch new scrobbles.
- **Last.fm Sync**: A background process that polls the Last.fm API every 60 seconds to fetch new scrobbles. Both syncs write to the same `scrobbles` table; duplicate timestamps are silently ignored.
- **Metadata Enrichment**: A background process that identifies scrobbles with missing metadata (genres, labels, release years) and fetches information from MusicBrainz, Last.fm, and Discogs.
-- **Cover Art Proxy**: A specialized endpoint that fetches, caches, and serves cover art, utilizing a multi-source fallback strategy (CAA → Last.fm → Discogs).
-- **Observability**: Prometheus metrics exposed at `/metrics`.
+- **Cover Art Proxy**: A specialized endpoint that redirects to cover art and caches it in the background, using the fallback strategy Cover Art Archive → Discogs → Last.fm.
+- **Registration and administration**: An optional public registration flow with authenticated approval, user provisioning, and SMTP notifications.
+- **Observability**: Optional Prometheus metrics exposed at `/metrics`.
### Frontend
A Single Page Application (SPA) built with [Elm](https://elm-lang.org).
- **Performance**: DuckDB's columnar storage allows for extremely fast analytical queries across large listening histories.
### Storage
-Uses an S3-compatible bucket to cache cover art images.
-- **Caching Strategy**: Images are fetched once from external APIs and stored in S3 to reduce latency and avoid rate-limiting on external services.
+Uses an S3-compatible bucket for cover art and optional database backups.
+- **Cover cache**: Cached images are converted to AVIF and stored in S3. Cache hits redirect to a presigned S3 URL; cache misses redirect to the upstream image and populate the cache in the background.
+- **Backups**: When enabled per user, the server checkpoints that user's DuckDB database and uploads timestamped snapshots to S3.
+- **Registration data**: Pending, approved, denied, and revoked self-registration requests are stored separately in the shared `registrations.db` database.
## Multi-User Support
### Routing
- `/` and `/u/<slug>` — serve the Elm SPA for the root user and named users respectively
-- `/proxy?user=<slug>`, `/stats?user=<slug>`, `/cover?user=<slug>` — shared API endpoints, user selected via query parameter
+- `/proxy?user=<slug>`, `/stats?user=<slug>`, `/cover?user=<slug>`, `/similar?user=<slug>` — shared API endpoints, user selected via query parameter
- `/healthz?user=<slug>` — liveness check; pings the user's DuckDB connection
+- `/1/validate-token` — ListenBrainz-compatible token validation endpoint
- `/1/submit-listens` — ListenBrainz-compatible scrobble submission endpoint (requires `Authorization: Token <token>` header)
+- `/register` and `/admin` — registration and administration UI; registration is enabled with `REGISTRATION_ENABLED=true`, while admin API routes additionally require `ADMIN_TOKEN`
- `/metrics` — Prometheus metrics (no user parameter; covers all users; only available when `METRICS_ENABLED=true`)
### User Management
Each user gets their own `UserContext` with an independent DuckDB connection, sync loop, and write lock (`AVar Unit`). The write lock serializes all sync transactions — if a user has both ListenBrainz and Last.fm configured, their transactions are queued rather than run concurrently. HTTP reads do not acquire the lock; DuckDB's MVCC provides consistent snapshots.
-### Graceful Shutdown
+Approved self-registered users are provisioned immediately and loaded at startup from `registrations.db`; `users.json` is not changed. A user defined in `users.json` takes precedence over an approved registration with the same slug.
-The server implements graceful shutdown handling to ensure clean termination of all background processes. When the server receives a shutdown signal, it:
+### Removing Registered Users
-1. **Kills background fibers**: Terminates all running background tasks (metadata enrichment, database backups) for each user
-2. **Closes database connections**: Properly closes all DuckDB connections
-3. **Logs cleanup progress**: Provides detailed logging during the shutdown process
+An administrator can remove a self-registered user without restarting the server. Corpus stops that user's recurring sync, enrichment, and backup fibers; removes the live user context; closes and deletes the user's DuckDB file; and marks the registration as revoked. Users defined in `users.json` are managed manually and cannot be removed through this flow.
-This prevents data corruption and ensures that any in-progress operations are completed or safely aborted before the server exits.
-
## Configuration Reference
### Environment Variables
| `AWS_S3_ADDRESSING_STYLE` | — | `virtual` or `path` |
| `COSINE_API_KEY` | — | [cosine.club](https://cosine.club) API key for similar tracks |
| `PORT` | `8000` | HTTP listen port |
+| `HOST` | `127.0.0.1` | HTTP listen host |
| `METRICS_ENABLED` | `false` | Set to `true` to enable the Prometheus `/metrics` endpoint |
+| `CORS_ORIGIN` | `*` | Value of `Access-Control-Allow-Origin` on `/proxy` responses |
+| `REGISTRATION_ENABLED` | `false` | Set to `true` to enable public registration at `/register` |
+| `ADMIN_TOKEN` | — | Bearer token required by `/admin/*` API routes; when unset, they return 404 |
+| `ADMIN_EMAIL` | — | Address notified of new registration requests |
+| `CORPUS_REGISTRATIONS_DB` | `registrations.db` | Shared DuckDB file for registration state |
+| `SMTP_HOST` | — | SMTP server host; email is skipped when unset |
+| `SMTP_PORT` | `587` | SMTP port (STARTTLS) |
+| `SMTP_USER` | — | SMTP username |
+| `SMTP_PASS` | — | SMTP password |
+| `SMTP_FROM` | — | Sender address |
### users.json Fields
1. Check S3 cache.
2. If not found:
- Try **Cover Art Archive (CAA)** using the Release MBID.
- - Fallback to **Last.fm** using Artist/Album name.
- - Final fallback to **Discogs** search API.
-3. If found in any source, the image is proxied to the client and uploaded to S3 in the background.
+ - Fallback to **Discogs** using Artist/Album name.
+ - Final fallback to **Last.fm** using Artist/Album name.
+3. The client is redirected to the selected source immediately. If caching is enabled, Corpus fetches, converts, and uploads the image to S3 in the background.
## Observability
| `corpus_enrichment_fetches_total` | Counter | `user`, `source`, `result` | Metadata enrichment API calls |
| `corpus_enrichment_queue_size` | Gauge | `user`, `type` | Releases pending enrichment |
| `corpus_cover_requests_total` | Counter | `user`, `source`, `result` | Cover art requests |
+| `corpus_cosine_requests_total` | Counter | `user`, `result` | Similar-track lookup requests |
| `corpus_db_backup_runs_total` | Counter | `user`, `result` | Database backup runs |
| `corpus_db_backup_last_success_seconds` | Gauge | `user` | Timestamp of last successful backup |
blob - 6443c379b679b525d8ed41f0df39b0927bce5c98
blob + 4ede4acaf3601eb61f4fd8869a10c146ff06be9c
--- docs/duckdb.md
+++ docs/duckdb.md
## Database Schema
-The database consists of two main tables:
+Each user has an independent DuckDB database file. That database consists of three main tables:
### `scrobbles`
Stores the raw listening history synced from ListenBrainz and/or Last.fm.
| `slug` | VARCHAR | User slug (Primary Key) |
| `hashed_token` | VARCHAR | SHA-256 hash of the API token (Unique) |
+Self-registration state is intentionally kept outside the per-user databases in the shared `registrations.db` file. It is managed by the server rather than by the listening-history schema.
+
## Application Usage
The application interacts with DuckDB via a PureScript FFI layer (`src/Db.js` and `src/Db.purs`).
blob - 7eb18dc8f5f34813c0ceca1d765a862f5df6c185
blob + 46b5aea6a228edaa63fa95609bf10af96a4e0d49
--- src/Main.purs
+++ src/Main.purs
import Data.Tuple (Tuple(..), fst)
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, joinFiber, killFiber, launchAff_, try)
+import Effect.Aff (Aff, Fiber, forkAff, killFiber, launchAff_, try)
import Effect.Aff.AVar (AVar)
import Effect.Aff.AVar as Avar
import Effect.Class (liftEffect)
, config :: UserConfig
, slug :: String
, displayName :: String
+ , isRegistered :: Boolean
+ , initialSyncFibers :: Array (Fiber Unit)
, enrichMetadataFiber :: Maybe (Fiber Unit)
, backupFiber :: Maybe (Fiber Unit)
, syncFibers :: Array (Fiber Unit)
case mReg of
Nothing ->
liftEffect $ serveNotFound res
- Just reg -> do
- Reg.setStatus env.regConn env.regLock id "denied"
- notifyDenied env reg
- liftEffect $ respond "application/json" 200 """{"status":"denied"}""" res
+ Just reg ->
+ if reg.status /= "pending" then
+ liftEffect $ serveBadRequest res "Registration is not pending"
+ else do
+ Reg.setStatus env.regConn env.regLock id "denied"
+ notifyDenied env reg
+ 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"
- liftEffect $ respond "application/json" 200 (stringify $ encodeJson (map regToJson regs)) res
+ 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
serveRemoveUser :: ServerEnv -> Request -> Response -> Aff Unit
serveRemoveUser env req res = do
if reg.status /= "approved" then
liftEffect $ serveBadRequest res "User is not active"
else do
- removeUser env reg
- liftEffect $ respond "application/json" 200 """{"status":"removed"}""" res
+ removed <- removeUser env reg
+ if removed then
+ liftEffect $ respond "application/json" 200 """{"status":"removed"}""" res
+ else
+ 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
-- gone across restarts and the slug frees up for re-registration).
-removeUser :: ServerEnv -> Reg.Registration -> Aff Unit
+removeUser :: ServerEnv -> Reg.Registration -> Aff Boolean
removeUser env reg = do
contexts <- liftEffect $ Ref.read env.contextsRef
- for_ (find (\c -> c.slug == reg.slug) contexts) \ctx -> do
- cleanupUser ctx
- liftEffect $ Ref.modify_ (Data.Array.filter (\c -> c.slug /= reg.slug)) env.contextsRef
- void $ try $ closeConnection ctx.conn
- void $ try $ FSA.unlink ctx.config.databaseFile
- Reg.setStatus env.regConn env.regLock reg.id "revoked"
+ case find (\ctx -> ctx.slug == reg.slug && ctx.isRegistered) contexts of
+ Nothing ->
+ pure false
+ Just ctx -> do
+ cleanupUser ctx
+ 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"
+ pure true
-- Builds a runnable UserEntry from an approved registration (users.json is not touched).
registrationUserEntry :: Reg.Registration -> Aff UserEntry
provisionUser :: ServerEnv -> Reg.Registration -> Aff (Maybe String)
provisionUser env reg = do
entry <- registrationUserEntry reg
- Tuple ctx mToken <- startUser entry
+ Tuple ctx mToken <- startUser true entry
liftEffect $ Ref.modify_ (\cs -> snoc cs ctx) env.contextsRef
pure mToken
}
}
-startUser :: UserEntry -> Aff (Tuple UserContext (Maybe String))
-startUser { slug, name, config } = do
+startUser :: Boolean -> UserEntry -> Aff (Tuple UserContext (Maybe String))
+startUser isRegistered { slug, name, config } = do
Log.info $ "Starting user: " <> if slug == "" then "(root)" else slug
conn <- connect config.databaseFile
initDb conn
Just _, Nothing -> Log.warn $ "User '" <> slug <> "': Last.fm sync disabled (missing API key)"
_, _ -> pure unit
- lbFiber <- case config.listenbrainzUser of
- Just username -> Just <$> forkAff (lbSync conn username slug writeLock)
- Nothing -> pure Nothing
- lfFiber <- case config.lastfmUser, config.lastfmApiKey of
- Just lfmUser, Just apiKey -> Just <$> forkAff (lfSync conn apiKey lfmUser slug writeLock)
- _, _ -> pure Nothing
+ initialSyncFibers <- traverse forkAff
+ $
+ [ case config.listenbrainzUser of
+ 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
+ _, _ -> Nothing
+ ] # Data.Array.mapMaybe identity
- -- Join the initial sync fibers so their completion is logged before loops start.
- void $ forkAff do
- for_ lbFiber joinFiber
- for_ lfFiber joinFiber
-
-- Spawn the recurring sync loops eagerly; each starts with a 60s delay so
-- they won't race with the initial sync above. Track them so cleanupUser
-- can kill them on shutdown.
let displayName = fromMaybe (if slug == "" then "root" else slug) name
pure $ Tuple
- { conn, writeLock, config, slug, displayName, enrichMetadataFiber: Just enrichMetadataFiber, backupFiber, syncFibers: loopFibers }
+ { conn, writeLock, config, slug, displayName, isRegistered, initialSyncFibers, enrichMetadataFiber: Just enrichMetadataFiber, backupFiber, syncFibers: loopFibers }
mToken
cleanupUser :: UserContext -> Aff Unit
cleanupUser ctx = do
let label = if ctx.slug == "" then "(root)" else ctx.slug
Log.info $ "Shutting down user: " <> label
+ for_ ctx.initialSyncFibers \fiber ->
+ void $ try $ killFiber (Exception.error "Server shutting down") fiber
for_ ctx.enrichMetadataFiber \fiber ->
void $ try $ killFiber (Exception.error "Server shutting down") fiber
for_ ctx.backupFiber \fiber ->
liftEffect $ Exception.throwException err
Right (appConfig :: AppConfig) -> do
Log.info $ "Loaded " <> show (length appConfig.users) <> " user(s) from " <> configFile
- results <- traverse startUser appConfig.users
+ results <- traverse (startUser false) appConfig.users
let jsonContexts = map fst results
-- Also start approved registrations, skipping slugs already in users.json.
regConn <- connect appConfig.registrationsDb
$ Log.info
$ "Starting " <> show (length toStart) <> " approved registered user(s)"
approvedEntries <- traverse registrationUserEntry toStart
- approvedResults <- traverse startUser approvedEntries
+ approvedResults <- traverse (startUser true) approvedEntries
let contexts = jsonContexts <> map fst approvedResults
contextsRef <- liftEffect $ Ref.new contexts
regLock <- Avar.new unit
blob - d6243865ab95c8afde0b0abd5afe6420cfa7ece5
blob + e9b6c4cdda03f33ba3d693dd51a152ec69713620
--- src/S3.js
+++ src/S3.js
.then((url) => cb(null)(url)())
.catch((err) => cb(err)("")());
};
-
-export const getS3UrlImpl = (cfg, key) => {
- const endpoint = cfg.endpointUrl || "";
- const bucket = cfg.bucket || "";
- if (cfg.addressingStyle === "path") {
- return `${endpoint}/${bucket}/${key}`;
- } else {
- return `${endpoint.replace("://", `://${bucket}.`)}/${key}`;
- }
-};
blob - 6bf33fa7e2e92a1716418481a95201958ef6d2e1
blob + d830d47934c4ecd195aa04cba46b1c9890a7f7a7
--- src/S3.purs
+++ src/S3.purs
import Config (S3Config)
import Data.Either (Either(..))
-import Data.Function.Uncurried (Fn2, Fn3, Fn5, runFn2, runFn3, runFn5)
+import Data.Function.Uncurried (Fn3, Fn5, runFn3, runFn5)
import Data.Maybe (Maybe(..))
import Data.Nullable (Nullable, toMaybe, toNullable)
import Effect (Effect)
foreign import getPresignedUrlImpl
:: Fn3 S3ConfigJs String (Nullable Error -> String -> Effect Unit) (Effect Unit)
-foreign import getS3UrlImpl :: Fn2 S3ConfigJs String String
-
uploadToS3 :: S3Config -> String -> Buffer -> String -> Aff Unit
uploadToS3 cfg key body contentType = makeAff \cb -> do
runFn5 uploadToS3Impl (toJs cfg) key body contentType \err ->
Just e -> cb (Left e)
Nothing -> cb (Right url)
pure nonCanceler
-
-getS3Url :: S3Config -> String -> String
-getS3Url cfg key = runFn2 getS3UrlImpl (toJs cfg) key
blob - a5ed32f417c2c97ec18386b4cbcbc55de08ea135
blob + 765629aed91ad38fd7c79af8b63861dc21c51e2c
--- test/Main.purs
+++ test/Main.purs
import Registrations (getById, initRegistrations, insertRegistration, isReservedSlug, listByStatus, setStatus, slugTaken, validSlugFormat)
import Cover (sanitizeKey)
import Sync (listenBrainzUrl, lastfmTrackToListen, parseLastfmResponse)
-import S3 (getS3Url)
main :: Effect Unit
-main = runSpecAndExitProcess [consoleReporter] do
- describe "Corpus Main Utils" do
- it "should build ListenBrainz URLs correctly" do
- listenBrainzUrl "user1" `shouldEqual` "https://api.listenbrainz.org/1/user/user1/listens"
+main = runSpecAndExitProcess [ consoleReporter ] do
+ describe "Corpus Main Utils" do
+ it "should build ListenBrainz URLs correctly" do
+ 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")
- let re2 = regex "_{2,}" (parseFlags "g")
- let re3 = regex "[^0-9\\-]" (parseFlags "g")
- isRight re1 `shouldEqual` true
- isRight re2 `shouldEqual` true
- isRight re3 `shouldEqual` true
+ it "regex patterns should compile successfully" do
+ let re1 = regex "[^a-z0-9.-]" (parseFlags "gi")
+ let re2 = regex "_{2,}" (parseFlags "g")
+ let re3 = regex "[^0-9\\-]" (parseFlags "g")
+ isRight re1 `shouldEqual` true
+ isRight re2 `shouldEqual` true
+ isRight re3 `shouldEqual` true
- it "should sanitize S3 keys correctly" do
- sanitizeKey "hello world!" `shouldEqual` "hello_world_"
- sanitizeKey "T.est-123" `shouldEqual` "T.est-123"
- sanitizeKey "multiple spaces" `shouldEqual` "multiple_spaces"
+ it "should sanitize S3 keys correctly" do
+ sanitizeKey "hello world!" `shouldEqual` "hello_world_"
+ sanitizeKey "T.est-123" `shouldEqual` "T.est-123"
+ sanitizeKey "multiple spaces" `shouldEqual` "multiple_spaces"
- it "should sanitize S3 keys - edge cases" do
- sanitizeKey "" `shouldEqual` ""
- sanitizeKey "already-clean" `shouldEqual` "already-clean"
- sanitizeKey "a@#b$c%d" `shouldEqual` "a_b_c_d"
- sanitizeKey "___" `shouldEqual` "_"
- sanitizeKey "a...b" `shouldEqual` "a...b"
- sanitizeKey "UPPER lower" `shouldEqual` "UPPER_lower"
+ it "should sanitize S3 keys - edge cases" do
+ sanitizeKey "" `shouldEqual` ""
+ sanitizeKey "already-clean" `shouldEqual` "already-clean"
+ sanitizeKey "a@#b$c%d" `shouldEqual` "a_b_c_d"
+ sanitizeKey "___" `shouldEqual` "_"
+ sanitizeKey "a...b" `shouldEqual` "a...b"
+ sanitizeKey "UPPER lower" `shouldEqual` "UPPER_lower"
- describe "fromString" do
- it "maps all valid field names" do
- fromString "artist" `shouldEqual` Just FilterArtist
- fromString "album" `shouldEqual` Just FilterAlbum
- fromString "label" `shouldEqual` Just FilterLabel
- fromString "year" `shouldEqual` Just FilterYear
- fromString "genre" `shouldEqual` Just FilterGenre
+ describe "fromString" do
+ it "maps all valid field names" do
+ fromString "artist" `shouldEqual` Just FilterArtist
+ fromString "album" `shouldEqual` Just FilterAlbum
+ fromString "label" `shouldEqual` Just FilterLabel
+ fromString "year" `shouldEqual` Just FilterYear
+ fromString "genre" `shouldEqual` Just FilterGenre
- it "returns Nothing for unknown or empty input" do
- fromString "unknown" `shouldEqual` Nothing
- fromString "" `shouldEqual` Nothing
+ it "returns Nothing for unknown or empty input" do
+ fromString "unknown" `shouldEqual` Nothing
+ fromString "" `shouldEqual` Nothing
- describe "sanitizeDate" do
- it "strips non-numeric characters except hyphens" do
- sanitizeDate "2024-01-15" `shouldEqual` "2024-01-15"
- sanitizeDate "2024/01/15" `shouldEqual` "20240115"
- sanitizeDate "Jan 15, 2024" `shouldEqual` "152024"
- sanitizeDate "2024-01-15T10:30:00" `shouldEqual` "2024-01-15103000"
+ describe "sanitizeDate" do
+ it "strips non-numeric characters except hyphens" do
+ sanitizeDate "2024-01-15" `shouldEqual` "2024-01-15"
+ sanitizeDate "2024/01/15" `shouldEqual` "20240115"
+ sanitizeDate "Jan 15, 2024" `shouldEqual` "152024"
+ sanitizeDate "2024-01-15T10:30:00" `shouldEqual` "2024-01-15103000"
- it "handles edge cases" do
- sanitizeDate "" `shouldEqual` ""
- sanitizeDate "12345" `shouldEqual` "12345"
- sanitizeDate "abc" `shouldEqual` ""
+ it "handles edge cases" do
+ sanitizeDate "" `shouldEqual` ""
+ sanitizeDate "12345" `shouldEqual` "12345"
+ sanitizeDate "abc" `shouldEqual` ""
- describe "ListenBrainz Submission" do
- it "should decode a ListenBrainz submission payload" do
- let jsonStr = """
+ describe "ListenBrainz Submission" do
+ it "should decode a ListenBrainz submission payload" do
+ let
+ jsonStr =
+ """
{
"listen_type": "single",
"payload": [
]
}
"""
- let result = parseJson jsonStr >>= decodeJson
- case result of
- Right (ListenBrainzSubmitPayload { listenType, payload }) -> do
- listenType `shouldEqual` "single"
- length payload `shouldEqual` 1
- case payload of
- [ListenBrainzSubmitListen { listenedAt, trackMetadata: ListenBrainzSubmitTrackMetadata m }] -> do
- listenedAt `shouldEqual` Just 123456789
- m.trackName `shouldEqual` "Song Name"
- m.artistName `shouldEqual` "Artist Name"
- m.releaseName `shouldEqual` Just "Album Name"
- case m.additionalInfo of
- Just (ListenBrainzAdditionalInfo info) -> do
- info.releaseMbid `shouldEqual` Just "rel-mbid"
- Nothing -> do
- fail "Expected additional_info"
- _ -> do
- fail "Expected 1 listen"
- Left err -> do
- fail $ "Decoding failed: " <> show err
+ let result = parseJson jsonStr >>= decodeJson
+ case result of
+ Right (ListenBrainzSubmitPayload { listenType, payload }) -> do
+ listenType `shouldEqual` "single"
+ length payload `shouldEqual` 1
+ case payload of
+ [ ListenBrainzSubmitListen { listenedAt, trackMetadata: ListenBrainzSubmitTrackMetadata m } ] -> do
+ listenedAt `shouldEqual` Just 123456789
+ m.trackName `shouldEqual` "Song Name"
+ m.artistName `shouldEqual` "Artist Name"
+ m.releaseName `shouldEqual` Just "Album Name"
+ case m.additionalInfo of
+ Just (ListenBrainzAdditionalInfo info) -> do
+ info.releaseMbid `shouldEqual` Just "rel-mbid"
+ Nothing -> do
+ fail "Expected additional_info"
+ _ -> do
+ fail "Expected 1 listen"
+ Left err -> do
+ fail $ "Decoding failed: " <> show err
- it "should convert ListenBrainzSubmitListen to Listen correctly" do
- let submission = ListenBrainzSubmitListen
- { listenedAt: Just 123456789
- , trackMetadata: ListenBrainzSubmitTrackMetadata
- { trackName: "Song Name"
- , artistName: "Artist Name"
- , releaseName: Just "Album Name"
- , additionalInfo: Just (ListenBrainzAdditionalInfo
+ it "should convert ListenBrainzSubmitListen to Listen correctly" do
+ let
+ submission = ListenBrainzSubmitListen
+ { listenedAt: Just 123456789
+ , trackMetadata: ListenBrainzSubmitTrackMetadata
+ { trackName: "Song Name"
+ , artistName: "Artist Name"
+ , releaseName: Just "Album Name"
+ , additionalInfo: Just
+ ( ListenBrainzAdditionalInfo
{ releaseMbid: Just "rel-mbid"
- , artistMbids: Just ["art-mbid"]
+ , artistMbids: Just [ "art-mbid" ]
, recordingMbid: Just "rec-mbid"
- })
- }
+ }
+ )
}
- case submitListenToListen "single" submission of
- Just (Listen { listenedAt, trackMetadata: TrackMetadata m }) -> do
- listenedAt `shouldEqual` Just 123456789
- 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" })
- Nothing -> do
- fail "Conversion failed"
+ }
+ case submitListenToListen "single" submission of
+ Just (Listen { listenedAt, trackMetadata: TrackMetadata m }) -> do
+ listenedAt `shouldEqual` Just 123456789
+ 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" })
+ Nothing -> do
+ fail "Conversion failed"
- it "should ignore playing_now listens" do
- let submission = ListenBrainzSubmitListen
- { listenedAt: Nothing
- , trackMetadata: ListenBrainzSubmitTrackMetadata
- { trackName: "Song Name"
- , artistName: "Artist Name"
- , releaseName: Nothing
- , additionalInfo: Nothing
- }
+ it "should ignore playing_now listens" do
+ let
+ submission = ListenBrainzSubmitListen
+ { listenedAt: Nothing
+ , trackMetadata: ListenBrainzSubmitTrackMetadata
+ { trackName: "Song Name"
+ , artistName: "Artist Name"
+ , releaseName: Nothing
+ , additionalInfo: Nothing
}
- submitListenToListen "playing_now" submission `shouldEqual` Nothing
+ }
+ submitListenToListen "playing_now" submission `shouldEqual` Nothing
- it "should convert an import listen the same as a single listen" do
- let submission = ListenBrainzSubmitListen
- { listenedAt: Just 987654321
- , trackMetadata: ListenBrainzSubmitTrackMetadata
- { trackName: "Imported Song"
- , artistName: "Imported Artist"
- , releaseName: Just "Imported Album"
- , additionalInfo: Nothing
- }
+ it "should convert an import listen the same as a single listen" do
+ let
+ submission = ListenBrainzSubmitListen
+ { listenedAt: Just 987654321
+ , trackMetadata: ListenBrainzSubmitTrackMetadata
+ { trackName: "Imported Song"
+ , artistName: "Imported Artist"
+ , releaseName: Just "Imported Album"
+ , additionalInfo: Nothing
}
- case submitListenToListen "import" submission of
- Just (Listen { listenedAt, trackMetadata: TrackMetadata m }) -> do
- listenedAt `shouldEqual` Just 987654321
- m.trackName `shouldEqual` Just "Imported Song"
- m.artistName `shouldEqual` Just "Imported Artist"
- m.releaseName `shouldEqual` Just "Imported Album"
- m.mbidMapping `shouldEqual` Nothing
- Nothing -> do
- fail "Conversion failed"
+ }
+ case submitListenToListen "import" submission of
+ Just (Listen { listenedAt, trackMetadata: TrackMetadata m }) -> do
+ listenedAt `shouldEqual` Just 987654321
+ m.trackName `shouldEqual` Just "Imported Song"
+ m.artistName `shouldEqual` Just "Imported Artist"
+ m.releaseName `shouldEqual` Just "Imported Album"
+ m.mbidMapping `shouldEqual` Nothing
+ Nothing -> do
+ fail "Conversion failed"
- it "should ignore unknown listen types" do
- let submission = ListenBrainzSubmitListen
- { listenedAt: Nothing
- , trackMetadata: ListenBrainzSubmitTrackMetadata
- { trackName: "Song Name"
- , artistName: "Artist Name"
- , releaseName: Nothing
- , additionalInfo: Nothing
- }
+ it "should ignore unknown listen types" do
+ let
+ submission = ListenBrainzSubmitListen
+ { listenedAt: Nothing
+ , trackMetadata: ListenBrainzSubmitTrackMetadata
+ { trackName: "Song Name"
+ , artistName: "Artist Name"
+ , releaseName: Nothing
+ , additionalInfo: Nothing
}
- submitListenToListen "bogus" submission `shouldEqual` Nothing
+ }
+ submitListenToListen "bogus" submission `shouldEqual` Nothing
- describe "ListenBrainz validate-token" do
- it "extracts the token from a 'Token <token>' Authorization header" do
- parseAuthToken (Just "Token abc-123") `shouldEqual` Just "abc-123"
+ describe "ListenBrainz validate-token" do
+ it "extracts the token from a 'Token <token>' Authorization header" do
+ parseAuthToken (Just "Token abc-123") `shouldEqual` Just "abc-123"
- it "rejects a missing or malformed Authorization header" do
- parseAuthToken Nothing `shouldEqual` Nothing
- parseAuthToken (Just "Bearer abc-123") `shouldEqual` Nothing
- parseAuthToken (Just "token abc-123") `shouldEqual` Nothing
+ it "rejects a missing or malformed Authorization header" do
+ parseAuthToken Nothing `shouldEqual` Nothing
+ parseAuthToken (Just "Bearer abc-123") `shouldEqual` Nothing
+ parseAuthToken (Just "token abc-123") `shouldEqual` Nothing
- it "builds a valid-token response with the user name" do
- let body = validateTokenJson (Just "User One")
- let result = parseJson body >>= decodeJson :: _ (Object.Object Json)
- 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 "code" obj >>= toNumber) `shouldEqual` Just 200.0
- Left _ ->
- fail "validateTokenJson did not produce valid JSON"
+ it "builds a valid-token response with the user name" do
+ let body = validateTokenJson (Just "User One")
+ let result = parseJson body >>= decodeJson :: _ (Object.Object Json)
+ 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 "code" obj >>= toNumber) `shouldEqual` Just 200.0
+ Left _ ->
+ fail "validateTokenJson did not produce valid JSON"
- it "builds an invalid-token response for an unknown token" do
- let body = validateTokenJson Nothing
- let result = parseJson body >>= decodeJson :: _ (Object.Object Json)
- case result of
- Right obj -> do
- (Object.lookup "valid" obj >>= toBoolean) `shouldEqual` Just false
- Object.member "user_name" obj `shouldEqual` false
- Left _ ->
- fail "validateTokenJson did not produce valid JSON"
+ it "builds an invalid-token response for an unknown token" do
+ let body = validateTokenJson Nothing
+ let result = parseJson body >>= decodeJson :: _ (Object.Object Json)
+ case result of
+ Right obj -> do
+ (Object.lookup "valid" obj >>= toBoolean) `shouldEqual` Just false
+ Object.member "user_name" obj `shouldEqual` false
+ Left _ ->
+ fail "validateTokenJson did not produce valid JSON"
- describe "Token Authentication" do
- it "should create and verify tokens" do
- conn <- connect ":memory:"
- initDb conn
- mToken <- getOrCreateToken conn "user1"
- case mToken of
- Nothing -> do
- fail "Failed to create token"
- Just token -> do
- mSlug <- getTokenUser conn token
- mSlug `shouldEqual` Just "user1"
+ describe "Token Authentication" do
+ it "should create and verify tokens" do
+ conn <- connect ":memory:"
+ initDb conn
+ mToken <- getOrCreateToken conn "user1"
+ case mToken of
+ Nothing -> do
+ fail "Failed to create token"
+ Just token -> do
+ mSlug <- getTokenUser conn token
+ mSlug `shouldEqual` Just "user1"
- mSlugWrong <- getTokenUser conn "wrong-token"
- mSlugWrong `shouldEqual` Nothing
+ mSlugWrong <- getTokenUser conn "wrong-token"
+ mSlugWrong `shouldEqual` Nothing
- it "should find user by token across multiple contexts" do
- conn1 <- connect ":memory:"
- initDb conn1
- conn2 <- connect ":memory:"
- initDb conn2
+ it "should find user by token across multiple contexts" do
+ conn1 <- connect ":memory:"
+ initDb conn1
+ conn2 <- connect ":memory:"
+ initDb conn2
- mToken1 <- getOrCreateToken conn1 "user1"
- mToken2 <- getOrCreateToken conn2 "user2"
+ mToken1 <- getOrCreateToken conn1 "user1"
+ mToken2 <- getOrCreateToken conn2 "user2"
- case mToken1, mToken2 of
- Just token1, Just token2 -> do
- let
- dummyConfig =
- { listenbrainzUser: Nothing
- , lastfmUser: Nothing
- , lastfmApiKey: Nothing
- , discogsToken: Nothing
- , cosineApiKey: Nothing
- , databaseFile: ""
- , s3Bucket: Nothing
- , s3Region: ""
- , awsAccessKeyId: Nothing
- , awsSecretAccessKey: Nothing
- , awsEndpointUrl: Nothing
- , awsS3AddressingStyle: Nothing
- , coverCacheEnabled: false
- , backupEnabled: false
- , backupIntervalHours: 0
- }
- lock1 <- Avar.new unit
- lock2 <- Avar.new unit
- let
- ctx1 = { conn: conn1, writeLock: lock1, config: dummyConfig, slug: "user1", displayName: "User 1", enrichMetadataFiber: Nothing, backupFiber: Nothing, syncFibers: [] }
- ctx2 = { conn: conn2, writeLock: lock2, config: dummyConfig, slug: "user2", displayName: "User 2", enrichMetadataFiber: Nothing, backupFiber: Nothing, syncFibers: [] }
- contexts = [ ctx1, ctx2 ]
+ case mToken1, mToken2 of
+ Just token1, Just token2 -> do
+ let
+ dummyConfig =
+ { listenbrainzUser: Nothing
+ , lastfmUser: Nothing
+ , lastfmApiKey: Nothing
+ , discogsToken: Nothing
+ , cosineApiKey: Nothing
+ , databaseFile: ""
+ , s3Bucket: Nothing
+ , s3Region: ""
+ , awsAccessKeyId: Nothing
+ , awsSecretAccessKey: Nothing
+ , awsEndpointUrl: Nothing
+ , awsS3AddressingStyle: Nothing
+ , coverCacheEnabled: false
+ , backupEnabled: false
+ , backupIntervalHours: 0
+ }
+ 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: [] }
+ contexts = [ ctx1, ctx2 ]
- res1 <- findUserByToken contexts token1
- map _.slug res1 `shouldEqual` Just "user1"
+ res1 <- findUserByToken contexts token1
+ map _.slug res1 `shouldEqual` Just "user1"
- res2 <- findUserByToken contexts token2
- map _.slug res2 `shouldEqual` Just "user2"
+ res2 <- findUserByToken contexts token2
+ map _.slug res2 `shouldEqual` Just "user2"
- resNone <- findUserByToken contexts "invalid"
- map _.slug resNone `shouldEqual` Nothing
- _, _ -> do
- fail "Failed to create tokens"
+ resNone <- findUserByToken contexts "invalid"
+ map _.slug resNone `shouldEqual` Nothing
+ _, _ -> do
+ fail "Failed to create tokens"
- describe "Corpus Types" do
- describe "MbidMapping Codecs" do
- it "should roundtrip MbidMapping" do
- let mbid = MbidMapping { releaseMbid: Just "release-123", caaReleaseMbid: Just "caa-456" }
- decodeJson (encodeJson mbid) `shouldEqual` Right mbid
+ describe "Corpus Types" do
+ describe "MbidMapping Codecs" do
+ it "should roundtrip MbidMapping" do
+ 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 }
- (parseJson jsonStr >>= decodeJson) `shouldEqual` Right expected
+ it "should decode MbidMapping with missing fields" do
+ let jsonStr = "{\"release_mbid\": \"abc\"}"
+ let expected = MbidMapping { releaseMbid: Just "abc", caaReleaseMbid: Nothing }
+ (parseJson jsonStr >>= decodeJson) `shouldEqual` Right expected
- describe "TrackMetadata Codecs" do
- it "should roundtrip TrackMetadata" do
- let meta = TrackMetadata
+ describe "TrackMetadata Codecs" do
+ it "should roundtrip TrackMetadata" do
+ let
+ meta = TrackMetadata
+ { trackName: Just "Song"
+ , artistName: Just "Artist"
+ , releaseName: Just "Album"
+ , mbidMapping: Just (MbidMapping { releaseMbid: Just "rb", caaReleaseMbid: Nothing })
+ , genre: Just "Rock"
+ , label: Nothing
+ }
+ decodeJson (encodeJson meta) `shouldEqual` Right meta
+
+ describe "Listen Codecs" do
+ it "should roundtrip Listen" do
+ let
+ listen = Listen
+ { trackMetadata: TrackMetadata
{ trackName: Just "Song"
, artistName: Just "Artist"
- , releaseName: Just "Album"
- , mbidMapping: Just (MbidMapping { releaseMbid: Just "rb", caaReleaseMbid: Nothing })
- , genre: Just "Rock"
+ , releaseName: Nothing
+ , mbidMapping: Nothing
+ , genre: Nothing
, label: Nothing
}
- decodeJson (encodeJson meta) `shouldEqual` Right meta
+ , listenedAt: Just 1600000000
+ }
+ decodeJson (encodeJson listen) `shouldEqual` Right listen
- describe "Listen Codecs" do
- it "should roundtrip Listen" do
- let listen = Listen
- { trackMetadata: TrackMetadata
- { trackName: Just "Song"
- , artistName: Just "Artist"
- , releaseName: Nothing
- , mbidMapping: Nothing
- , genre: Nothing
- , label: Nothing
- }
- , listenedAt: Just 1600000000
- }
- decodeJson (encodeJson listen) `shouldEqual` Right listen
+ describe "Stats Codecs" do
+ it "should roundtrip Stats" do
+ let
+ stats = Stats
+ { genres: [ StatsEntry { name: "Rock", count: 10 } ]
+ , labels: [ StatsEntry { name: "Label", count: 5 } ]
+ , years: [ StatsEntry { name: "2023", count: 15 } ]
+ , artists: [ StatsEntry { name: "Artist", count: 7 } ]
+ , tracks: [ StatsEntry { name: "Artist — Song", count: 3 } ]
+ }
+ decodeJson (encodeJson stats) `shouldEqual` Right stats
- describe "Stats Codecs" do
- it "should roundtrip Stats" do
- let stats = Stats
- { genres: [StatsEntry { name: "Rock", count: 10 }]
- , labels: [StatsEntry { name: "Label", count: 5 }]
- , years: [StatsEntry { name: "2023", count: 15 }]
- , artists: [StatsEntry { name: "Artist", count: 7 }]
- , tracks: [StatsEntry { name: "Artist — Song", count: 3 }]
- }
- decodeJson (encodeJson stats) `shouldEqual` Right stats
-
- describe "ListenBrainzResponse Codecs" do
- it "should decode a full ListenBrainz response" do
- let jsonStr = """
+ describe "ListenBrainzResponse Codecs" do
+ it "should decode a full ListenBrainz response" do
+ let
+ jsonStr =
+ """
{
"payload": {
"listens": [
}
}
"""
- let result = parseJson jsonStr >>= decodeJson
- case result of
- Right (ListenBrainzResponse { payload: Payload { listens } }) -> do
- length listens `shouldEqual` 1
- Left err ->
- fail $ "Decoding failed: " <> show err
+ let result = parseJson jsonStr >>= decodeJson
+ case result of
+ Right (ListenBrainzResponse { payload: Payload { listens } }) -> do
+ length listens `shouldEqual` 1
+ Left err ->
+ fail $ "Decoding failed: " <> show err
- describe "Corpus Database" do
- it "should handle scrobble and metadata operations" do
+ describe "Corpus Database" do
+ it "should handle scrobble and metadata operations" do
+ conn <- connect ":memory:"
+ initDb conn
+ initReleaseMetadata conn
+
+ exists1 <- checkExists conn 12345
+ exists1 `shouldEqual` false
+
+ let
+ listen = Listen
+ { trackMetadata: TrackMetadata
+ { trackName: Just "Song"
+ , artistName: Just "Artist"
+ , releaseName: Just "Album"
+ , mbidMapping: Just (MbidMapping { releaseMbid: Just "rb1", caaReleaseMbid: Nothing })
+ , genre: Nothing
+ , label: Nothing
+ }
+ , listenedAt: Just 12345
+ }
+ upsertScrobble conn listen
+
+ exists2 <- checkExists conn 12345
+ exists2 `shouldEqual` true
+
+ listens <- getScrobbles conn 10 0 Nothing Nothing
+ length listens `shouldEqual` 1
+
+ upsertReleaseMetadata conn "rb1" (Just "Rock") (Just "Label") (Just 2023)
+
+ listensWithGenre <- getScrobbles conn 10 0 Nothing Nothing
+ case listensWithGenre of
+ [ Listen { trackMetadata: TrackMetadata m } ] -> m.genre `shouldEqual` Just "Rock"
+ _ -> fail "Expected 1 listen"
+
+ Stats s <- getStats conn Nothing Nothing Nothing Nothing
+ length s.genres `shouldEqual` 1
+ length s.labels `shouldEqual` 1
+ length s.years `shouldEqual` 1
+ length s.artists `shouldEqual` 1
+ length s.tracks `shouldEqual` 1
+
+ -- Test Filtering (as mentioned in architecture.md)
+ 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
+ length listensEmpty `shouldEqual` 0
+
+ it "upsertScrobble is idempotent" do
+ conn <- connect ":memory:"
+ initDb conn
+ initReleaseMetadata conn
+ let
+ listen = Listen
+ { listenedAt: Just 55555
+ , trackMetadata: TrackMetadata
+ { trackName: Just "Song"
+ , artistName: Just "Artist"
+ , releaseName: Just "Album"
+ , mbidMapping: Just (MbidMapping { releaseMbid: Just "mb1", caaReleaseMbid: Nothing })
+ , genre: Nothing
+ , label: Nothing
+ }
+ }
+ upsertScrobble conn listen
+ upsertScrobble conn listen
+ listens <- getScrobbles conn 10 0 Nothing Nothing
+ length listens `shouldEqual` 1
+
+ describe "getScrobbles filter variants" do
+ it "filters by artist" do
conn <- connect ":memory:"
initDb conn
initReleaseMetadata conn
+ let
+ mkListen ts artist = Listen
+ { listenedAt: Just ts
+ , trackMetadata: TrackMetadata
+ { trackName: Just "Song"
+ , artistName: Just artist
+ , releaseName: Nothing
+ , mbidMapping: 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
+ length listens `shouldEqual` 1
+ listensNone <- getScrobbles conn 10 0 (Just { field: FilterArtist, value: "Gamma" }) Nothing
+ length listensNone `shouldEqual` 0
- exists1 <- checkExists conn 12345
- exists1 `shouldEqual` false
+ it "filters by album" do
+ conn <- connect ":memory:"
+ initDb conn
+ initReleaseMetadata conn
+ let
+ mkListen artist release = Listen
+ { listenedAt: Just 1
+ , trackMetadata: TrackMetadata
+ { trackName: Just "Track"
+ , artistName: Just artist
+ , releaseName: Just release
+ , mbidMapping: Nothing
+ , genre: Nothing
+ , label: Nothing
+ }
+ }
+ upsertScrobble conn (mkListen "Artist" "Album A")
+ upsertScrobble conn (mkListen "Artist" "Album B")
+ 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
+ length listensNone `shouldEqual` 0
- let listen = Listen
- { trackMetadata: TrackMetadata
+ it "filters by label" do
+ conn <- connect ":memory:"
+ initDb conn
+ initReleaseMetadata conn
+ upsertScrobble conn
+ ( Listen
+ { listenedAt: Just 100
+ , trackMetadata: TrackMetadata
{ trackName: Just "Song"
, artistName: Just "Artist"
, releaseName: Just "Album"
- , mbidMapping: Just (MbidMapping { releaseMbid: Just "rb1", caaReleaseMbid: Nothing })
+ , mbidMapping: Just (MbidMapping { releaseMbid: Just "mb-label", caaReleaseMbid: Nothing })
, genre: Nothing
, label: Nothing
}
- , listenedAt: Just 12345
}
- upsertScrobble conn listen
-
- exists2 <- checkExists conn 12345
- exists2 `shouldEqual` true
-
- listens <- getScrobbles conn 10 0 Nothing Nothing
+ )
+ upsertReleaseMetadata conn "mb-label" Nothing (Just "Warp") (Just 2000)
+ 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
+ length listensNone `shouldEqual` 0
- upsertReleaseMetadata conn "rb1" (Just "Rock") (Just "Label") (Just 2023)
-
- listensWithGenre <- getScrobbles conn 10 0 Nothing Nothing
- case listensWithGenre of
- [Listen { trackMetadata: TrackMetadata m }] -> m.genre `shouldEqual` Just "Rock"
- _ -> fail "Expected 1 listen"
-
- Stats s <- getStats conn Nothing Nothing Nothing Nothing
- length s.genres `shouldEqual` 1
- length s.labels `shouldEqual` 1
- length s.years `shouldEqual` 1
- length s.artists `shouldEqual` 1
- length s.tracks `shouldEqual` 1
-
- -- Test Filtering (as mentioned in architecture.md)
- 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
- length listensEmpty `shouldEqual` 0
-
- it "upsertScrobble is idempotent" do
+ it "filters by year" do
conn <- connect ":memory:"
initDb conn
initReleaseMetadata conn
- let listen = Listen
- { listenedAt: Just 55555
+ upsertScrobble conn
+ ( Listen
+ { listenedAt: Just 200
, trackMetadata: TrackMetadata
{ trackName: Just "Song"
, artistName: Just "Artist"
, releaseName: Just "Album"
- , mbidMapping: Just (MbidMapping { releaseMbid: Just "mb1", caaReleaseMbid: Nothing })
+ , mbidMapping: Just (MbidMapping { releaseMbid: Just "mb-year", caaReleaseMbid: Nothing })
, genre: Nothing
, label: Nothing
}
}
- upsertScrobble conn listen
- upsertScrobble conn listen
- listens <- getScrobbles conn 10 0 Nothing Nothing
+ )
+ upsertReleaseMetadata conn "mb-year" Nothing Nothing (Just 1994)
+ 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
+ length listensNone `shouldEqual` 0
- describe "getScrobbles filter variants" do
- it "filters by artist" do
- conn <- connect ":memory:"
- initDb conn
- initReleaseMetadata conn
- let
- mkListen ts artist = Listen
- { listenedAt: Just ts
+ describe "getOldestTs" do
+ let
+ listenAt ts = Listen
+ { listenedAt: Just ts
+ , trackMetadata: TrackMetadata
+ { trackName: Just "T"
+ , artistName: Just "A"
+ , releaseName: Nothing
+ , mbidMapping: Nothing
+ , genre: Nothing
+ , label: Nothing
+ }
+ }
+ it "returns Nothing for an empty database" do
+ conn <- connect ":memory:"
+ initDb conn
+ result <- getOldestTs conn
+ result `shouldEqual` Nothing
+
+ it "returns the minimum listened_at" do
+ conn <- connect ":memory:"
+ initDb conn
+ upsertScrobble conn (listenAt 300)
+ upsertScrobble conn (listenAt 100)
+ upsertScrobble conn (listenAt 200)
+ result <- getOldestTs conn
+ result `shouldEqual` Just 100
+
+ describe "getUnenrichedMbids" do
+ let
+ listenWith ts mbid = Listen
+ { listenedAt: Just ts
+ , trackMetadata: TrackMetadata
+ { trackName: Just "T"
+ , artistName: Just "A"
+ , releaseName: Just "R"
+ , mbidMapping: Just (MbidMapping { releaseMbid: Just mbid, caaReleaseMbid: Nothing })
+ , genre: Nothing
+ , label: Nothing
+ }
+ }
+ it "returns MBIDs not yet in release_metadata" do
+ conn <- connect ":memory:"
+ initDb conn
+ initReleaseMetadata conn
+ upsertScrobble conn (listenWith 1000 "un-mbid")
+ mbids <- getUnenrichedMbids conn 10
+ mbids `shouldEqual` [ "un-mbid" ]
+
+ it "excludes MBIDs already in release_metadata" do
+ conn <- connect ":memory:"
+ initDb conn
+ initReleaseMetadata conn
+ upsertScrobble conn (listenWith 2000 "enriched")
+ upsertReleaseMetadata conn "enriched" (Just "Rock") (Just "Label") (Just 2020)
+ mbids <- getUnenrichedMbids conn 10
+ mbids `shouldEqual` []
+
+ it "excludes scrobbles with empty release_mbid" do
+ conn <- connect ":memory:"
+ initDb conn
+ initReleaseMetadata conn
+ upsertScrobble conn
+ ( Listen
+ { listenedAt: Just 3000
, trackMetadata: TrackMetadata
- { trackName: Just "Song"
- , artistName: Just artist
+ { trackName: Just "T"
+ , artistName: Just "A"
, releaseName: Nothing
, mbidMapping: 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
- length listens `shouldEqual` 1
- listensNone <- getScrobbles conn 10 0 (Just { field: FilterArtist, value: "Gamma" }) Nothing
- length listensNone `shouldEqual` 0
+ )
+ mbids <- getUnenrichedMbids conn 10
+ mbids `shouldEqual` []
- it "filters by album" do
- conn <- connect ":memory:"
- initDb conn
- initReleaseMetadata conn
- let mkListen artist release = Listen
- { listenedAt: Just 1
- , trackMetadata: TrackMetadata
- { trackName: Just "Track"
- , artistName: Just artist
- , releaseName: Just release
- , mbidMapping: Nothing
- , genre: Nothing
- , label: Nothing
- }
- }
- upsertScrobble conn (mkListen "Artist" "Album A")
- upsertScrobble conn (mkListen "Artist" "Album B")
- 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
- length listensNone `shouldEqual` 0
+ describe "getEmptyGenreMbids" do
+ let
+ listenWith ts mbid = Listen
+ { listenedAt: Just ts
+ , trackMetadata: TrackMetadata
+ { trackName: Just "T"
+ , artistName: Just "A"
+ , releaseName: Just "R"
+ , mbidMapping: Just (MbidMapping { releaseMbid: Just mbid, caaReleaseMbid: Nothing })
+ , genre: Nothing
+ , label: Nothing
+ }
+ }
+ it "returns MBIDs whose genre is null in release_metadata" do
+ conn <- connect ":memory:"
+ initDb conn
+ initReleaseMetadata conn
+ upsertScrobble conn (listenWith 4000 "eg-mbid")
+ upsertReleaseMetadata conn "eg-mbid" Nothing (Just "Label") (Just 2020)
+ mbids <- getEmptyGenreMbids conn 10
+ mbids `shouldEqual` [ "eg-mbid" ]
- it "filters by label" do
- conn <- connect ":memory:"
- initDb conn
- initReleaseMetadata conn
- upsertScrobble conn
- ( Listen
- { listenedAt: Just 100
- , trackMetadata: TrackMetadata
- { trackName: Just "Song"
- , artistName: Just "Artist"
- , releaseName: Just "Album"
- , 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
- length listens `shouldEqual` 1
- listensNone <- getScrobbles conn 10 0 (Just { field: FilterLabel, value: "Columbia" }) Nothing
- length listensNone `shouldEqual` 0
+ it "excludes MBIDs recently checked via touchGenreCheckedAt" do
+ conn <- connect ":memory:"
+ initDb conn
+ initReleaseMetadata conn
+ upsertScrobble conn (listenWith 5000 "touched")
+ upsertReleaseMetadata conn "touched" Nothing Nothing Nothing
+ touchGenreCheckedAt conn "touched"
+ mbids <- getEmptyGenreMbids conn 10
+ mbids `shouldEqual` []
- it "filters by year" do
- conn <- connect ":memory:"
- initDb conn
- initReleaseMetadata conn
- upsertScrobble conn
- ( Listen
- { listenedAt: Just 200
- , trackMetadata: TrackMetadata
- { trackName: Just "Song"
- , artistName: Just "Artist"
- , releaseName: Just "Album"
- , 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
- length listens `shouldEqual` 1
- listensNone <- getScrobbles conn 10 0 (Just { field: FilterYear, value: "1999" }) Nothing
- length listensNone `shouldEqual` 0
+ describe "getArtistReleasesByMbids" do
+ it "returns empty object for empty input" do
+ conn <- connect ":memory:"
+ initDb conn
+ result <- getArtistReleasesByMbids conn []
+ result `shouldEqual` Object.empty
- describe "getOldestTs" do
- let
- listenAt ts = Listen
- { listenedAt: Just ts
- , trackMetadata: TrackMetadata
- { trackName: Just "T"
- , artistName: Just "A"
- , releaseName: Nothing
- , mbidMapping: Nothing
- , genre: Nothing
- , label: Nothing
- }
- }
- it "returns Nothing for an empty database" do
- conn <- connect ":memory:"
- initDb conn
- result <- getOldestTs conn
- result `shouldEqual` Nothing
+ it "returns artist and release name indexed by MBID" do
+ conn <- connect ":memory:"
+ initDb conn
+ upsertScrobble conn
+ ( Listen
+ { listenedAt: Just 6000
+ , trackMetadata: TrackMetadata
+ { trackName: Just "Song"
+ , artistName: Just "My Artist"
+ , releaseName: Just "My Album"
+ , 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" }
- it "returns the minimum listened_at" do
- conn <- connect ":memory:"
- initDb conn
- upsertScrobble conn (listenAt 300)
- upsertScrobble conn (listenAt 100)
- upsertScrobble conn (listenAt 200)
- result <- getOldestTs conn
- result `shouldEqual` Just 100
+ describe "Corpus Backup" do
+ describe "dbBaseName" do
+ it "extracts base name from an absolute path" do
+ dbBaseName "/app/data/corpus.db" `shouldEqual` "corpus"
+ it "extracts base name from a nested path" do
+ dbBaseName "/tmp/test/mymusic.db" `shouldEqual` "mymusic"
+ it "returns the name without extension for a bare filename" do
+ dbBaseName "corpus.db" `shouldEqual` "corpus"
- describe "getUnenrichedMbids" do
- let
- listenWith ts mbid = Listen
- { listenedAt: Just ts
- , trackMetadata: TrackMetadata
- { trackName: Just "T"
- , artistName: Just "A"
- , releaseName: Just "R"
- , mbidMapping: Just (MbidMapping { releaseMbid: Just mbid, caaReleaseMbid: Nothing })
- , genre: Nothing
- , label: Nothing
- }
- }
- it "returns MBIDs not yet in release_metadata" do
- conn <- connect ":memory:"
- initDb conn
- initReleaseMetadata conn
- upsertScrobble conn (listenWith 1000 "un-mbid")
- mbids <- getUnenrichedMbids conn 10
- mbids `shouldEqual` [ "un-mbid" ]
+ describe "Last.fm Support" do
+ let
+ parseTrack :: String -> Json
+ parseTrack s = case parseJson s of
+ Right j -> j
+ Left _ -> encodeJson ([] :: Array Int) -- fallback that will produce Nothing
- it "excludes MBIDs already in release_metadata" do
- conn <- connect ":memory:"
- initDb conn
- initReleaseMetadata conn
- upsertScrobble conn (listenWith 2000 "enriched")
- upsertReleaseMetadata conn "enriched" (Just "Rock") (Just "Label") (Just 2020)
- mbids <- getUnenrichedMbids conn 10
- mbids `shouldEqual` []
-
- it "excludes scrobbles with empty release_mbid" do
- conn <- connect ":memory:"
- initDb conn
- initReleaseMetadata conn
- upsertScrobble conn
- ( Listen
- { listenedAt: Just 3000
- , trackMetadata: TrackMetadata
- { trackName: Just "T"
- , artistName: Just "A"
- , releaseName: Nothing
- , mbidMapping: Nothing
- , genre: Nothing
- , label: Nothing
- }
- }
- )
- mbids <- getUnenrichedMbids conn 10
- mbids `shouldEqual` []
-
- describe "getEmptyGenreMbids" do
+ describe "parseLastfmResponse" do
+ it "parses standard response with multiple tracks" do
let
- listenWith ts mbid = Listen
- { listenedAt: Just ts
- , trackMetadata: TrackMetadata
- { trackName: Just "T"
- , artistName: Just "A"
- , releaseName: Just "R"
- , mbidMapping: Just (MbidMapping { releaseMbid: Just mbid, caaReleaseMbid: Nothing })
- , genre: Nothing
- , label: Nothing
- }
- }
- it "returns MBIDs whose genre is null in release_metadata" do
- conn <- connect ":memory:"
- initDb conn
- initReleaseMetadata conn
- upsertScrobble conn (listenWith 4000 "eg-mbid")
- upsertReleaseMetadata conn "eg-mbid" Nothing (Just "Label") (Just 2020)
- mbids <- getEmptyGenreMbids conn 10
- mbids `shouldEqual` [ "eg-mbid" ]
-
- it "excludes MBIDs recently checked via touchGenreCheckedAt" do
- conn <- connect ":memory:"
- initDb conn
- initReleaseMetadata conn
- upsertScrobble conn (listenWith 5000 "touched")
- upsertReleaseMetadata conn "touched" Nothing Nothing Nothing
- touchGenreCheckedAt conn "touched"
- mbids <- getEmptyGenreMbids conn 10
- mbids `shouldEqual` []
-
- describe "getArtistReleasesByMbids" do
- it "returns empty object for empty input" do
- conn <- connect ":memory:"
- initDb conn
- result <- getArtistReleasesByMbids conn []
- result `shouldEqual` Object.empty
-
- it "returns artist and release name indexed by MBID" do
- conn <- connect ":memory:"
- initDb conn
- upsertScrobble conn
- ( Listen
- { listenedAt: Just 6000
- , trackMetadata: TrackMetadata
- { trackName: Just "Song"
- , artistName: Just "My Artist"
- , releaseName: Just "My Album"
- , 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" }
-
- describe "Corpus Backup" do
- describe "dbBaseName" do
- it "extracts base name from an absolute path" do
- dbBaseName "/app/data/corpus.db" `shouldEqual` "corpus"
- it "extracts base name from a nested path" do
- dbBaseName "/tmp/test/mymusic.db" `shouldEqual` "mymusic"
- it "returns the name without extension for a bare filename" do
- dbBaseName "corpus.db" `shouldEqual` "corpus"
-
- describe "Last.fm Support" do
- let parseTrack :: String -> Json
- parseTrack s = case parseJson s of
- Right j -> j
- Left _ -> encodeJson ([] :: Array Int) -- fallback that will produce Nothing
-
- describe "parseLastfmResponse" do
- it "parses standard response with multiple tracks" do
- let j = parseTrack """
+ j = parseTrack
+ """
{
"recenttracks": {
"track": [
}
}
"""
- case parseLastfmResponse j of
- Just { tracks, totalPages } -> do
- length tracks `shouldEqual` 2
- totalPages `shouldEqual` 10
- Nothing -> do
- fail "Should have parsed"
+ case parseLastfmResponse j of
+ Just { tracks, totalPages } -> do
+ length tracks `shouldEqual` 2
+ totalPages `shouldEqual` 10
+ Nothing -> do
+ fail "Should have parsed"
- it "parses response with a single track (as object)" do
- let j = parseTrack """
+ it "parses response with a single track (as object)" do
+ let
+ j = parseTrack
+ """
{
"recenttracks": {
"track": { "name": "Single Track" },
}
}
"""
- case parseLastfmResponse j of
- Just { tracks, totalPages } -> do
- length tracks `shouldEqual` 1
- totalPages `shouldEqual` 1
- Nothing -> do
- fail "Should have parsed single track object"
+ case parseLastfmResponse j of
+ Just { tracks, totalPages } -> do
+ length tracks `shouldEqual` 1
+ totalPages `shouldEqual` 1
+ Nothing -> do
+ fail "Should have parsed single track object"
- it "parses response with no tracks" do
- let j = parseTrack """
+ it "parses response with no tracks" do
+ let
+ j = parseTrack
+ """
{
"recenttracks": {
"@attr": { "totalPages": "0" }
}
}
"""
- case parseLastfmResponse j of
- Just { tracks, totalPages } -> do
- length tracks `shouldEqual` 0
- totalPages `shouldEqual` 0
- Nothing -> do
- fail "Should have parsed empty tracks"
+ case parseLastfmResponse j of
+ Just { tracks, totalPages } -> do
+ length tracks `shouldEqual` 0
+ totalPages `shouldEqual` 0
+ Nothing -> do
+ fail "Should have parsed empty tracks"
- it "parses response where totalPages is a number" do
- let j = parseTrack """
+ it "parses response where totalPages is a number" do
+ let
+ j = parseTrack
+ """
{
"recenttracks": {
"track": [],
}
}
"""
- case parseLastfmResponse j of
- Just { totalPages } -> do
- totalPages `shouldEqual` 5
- Nothing -> do
- fail "Should have parsed numeric totalPages"
+ case parseLastfmResponse j of
+ Just { totalPages } -> do
+ totalPages `shouldEqual` 5
+ Nothing -> do
+ fail "Should have parsed numeric totalPages"
- describe "lastfmTrackToListen" do
- it "parses a valid track with MBID" do
- let j = parseTrack """
+ describe "lastfmTrackToListen" do
+ it "parses a valid track with MBID" do
+ let
+ j = parseTrack
+ """
{
"name": "Test Track",
"artist": { "#text": "Test Artist" },
"date": { "uts": "1600000000", "#text": "13 Sep 2020, 12:00" }
}
"""
- case lastfmTrackToListen j of
- Nothing ->
- fail "Expected Just Listen, got Nothing"
- Just (Listen { listenedAt, trackMetadata: TrackMetadata m }) -> do
- listenedAt `shouldEqual` Just 1600000000
- 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" })
+ case lastfmTrackToListen j of
+ Nothing ->
+ fail "Expected Just Listen, got Nothing"
+ Just (Listen { listenedAt, trackMetadata: TrackMetadata m }) -> do
+ listenedAt `shouldEqual` Just 1600000000
+ 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" })
- it "treats empty album MBID as Nothing" do
- let j = parseTrack """
+ it "treats empty album MBID as Nothing" do
+ let
+ j = parseTrack
+ """
{
"name": "Track",
"artist": { "#text": "Artist" },
"date": { "uts": "1600000001", "#text": "13 Sep 2020, 12:01" }
}
"""
- case lastfmTrackToListen j of
- Nothing ->
- fail "Expected Just Listen, got Nothing"
- Just (Listen { trackMetadata: TrackMetadata m }) ->
- m.mbidMapping `shouldEqual` Just (MbidMapping { releaseMbid: Nothing, caaReleaseMbid: Nothing })
+ case lastfmTrackToListen j of
+ Nothing ->
+ fail "Expected Just Listen, got Nothing"
+ Just (Listen { trackMetadata: TrackMetadata m }) ->
+ m.mbidMapping `shouldEqual` Just (MbidMapping { releaseMbid: Nothing, caaReleaseMbid: Nothing })
- it "skips nowplaying tracks (no date field)" do
- let j = parseTrack """
+ it "skips nowplaying tracks (no date field)" do
+ let
+ j = parseTrack
+ """
{
"@attr": { "nowplaying": "true" },
"name": "Now Playing Track",
"album": { "#text": "Album", "mbid": "" }
}
"""
- lastfmTrackToListen j `shouldEqual` Nothing
+ lastfmTrackToListen j `shouldEqual` Nothing
- it "returns Nothing when artist field is missing" do
- let j = parseTrack """
+ it "returns Nothing when artist field is missing" do
+ let
+ j = parseTrack
+ """
{
"name": "Track",
"album": { "#text": "Album", "mbid": "" },
"date": { "uts": "1600000002", "#text": "13 Sep 2020, 12:02" }
}
"""
- lastfmTrackToListen j `shouldEqual` Nothing
+ lastfmTrackToListen j `shouldEqual` Nothing
- it "returns Nothing when date.uts is not a valid integer" do
- let j = parseTrack """
+ it "returns Nothing when date.uts is not a valid integer" do
+ let
+ j = parseTrack
+ """
{
"name": "Track",
"artist": { "#text": "Artist" },
"date": { "uts": "not-a-number", "#text": "?" }
}
"""
- lastfmTrackToListen j `shouldEqual` Nothing
+ lastfmTrackToListen j `shouldEqual` Nothing
- it "uses album MBID for both releaseMbid and caaReleaseMbid" do
- let j = parseTrack """
+ it "uses album MBID for both releaseMbid and caaReleaseMbid" do
+ let
+ j = parseTrack
+ """
{
"name": "Track",
"artist": { "#text": "Artist" },
"date": { "uts": "1600000003", "#text": "13 Sep 2020, 12:03" }
}
"""
- case lastfmTrackToListen j of
- 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" })
+ case lastfmTrackToListen j of
+ 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" })
- it "inserts and retrieves a Last.fm-style listen from the database" do
- conn <- connect ":memory:"
- initDb conn
- initReleaseMetadata conn
- let j = parseTrack """
+ it "inserts and retrieves a Last.fm-style listen from the database" do
+ conn <- connect ":memory:"
+ initDb conn
+ initReleaseMetadata conn
+ let
+ j = parseTrack
+ """
{
"name": "Last.fm Track",
"artist": { "#text": "Last.fm Artist" },
"date": { "uts": "1700000000", "#text": "14 Nov 2023, 22:13" }
}
"""
- case lastfmTrackToListen j of
- Nothing ->
- fail "lastfmTrackToListen returned Nothing"
- Just listen -> do
- upsertScrobble conn listen
- exists <- checkExists conn 1700000000
- exists `shouldEqual` true
- listens <- getScrobbles conn 10 0 Nothing Nothing
- length listens `shouldEqual` 1
+ case lastfmTrackToListen j of
+ Nothing ->
+ fail "lastfmTrackToListen returned Nothing"
+ Just listen -> do
+ upsertScrobble conn listen
+ exists <- checkExists conn 1700000000
+ exists `shouldEqual` true
+ listens <- getScrobbles conn 10 0 Nothing Nothing
+ length listens `shouldEqual` 1
- describe "Corpus S3" do
- it "should generate virtual-host style S3 URLs" do
- let
- cfg =
- { bucket: Just "my-bucket"
- , region: "us-east-1"
- , accessKeyId: Nothing
- , secretAccessKey: Nothing
- , endpointUrl: Just "https://s3.example.com"
- , addressingStyle: Just "virtual"
- }
- getS3Url cfg "covers/test.jpg" `shouldEqual` "https://my-bucket.s3.example.com/covers/test.jpg"
+ describe "Admin auth" do
+ it "parses Bearer tokens" do
+ parseBearer (Just "Bearer secret") `shouldEqual` Just "secret"
+ parseBearer (Just "Token secret") `shouldEqual` Nothing
+ parseBearer Nothing `shouldEqual` Nothing
- it "should generate path-style S3 URLs" do
- let
- cfg =
- { bucket: Just "my-bucket"
- , region: "us-east-1"
- , accessKeyId: Nothing
- , secretAccessKey: Nothing
- , endpointUrl: Just "https://s3.example.com"
- , addressingStyle: Just "path"
- }
- getS3Url cfg "covers/test.jpg" `shouldEqual` "https://s3.example.com/my-bucket/covers/test.jpg"
+ describe "Registrations" do
+ it "validates slug format" do
+ validSlugFormat "mtmn" `shouldEqual` true
+ validSlugFormat "a-b-1" `shouldEqual` true
+ validSlugFormat "Ab" `shouldEqual` false
+ validSlugFormat "-x" `shouldEqual` false
+ validSlugFormat "x-" `shouldEqual` false
+ validSlugFormat "" `shouldEqual` false
+ validSlugFormat "a b" `shouldEqual` false
- describe "Admin auth" do
- it "parses Bearer tokens" do
- parseBearer (Just "Bearer secret") `shouldEqual` Just "secret"
- parseBearer (Just "Token secret") `shouldEqual` Nothing
- parseBearer Nothing `shouldEqual` Nothing
+ it "flags reserved slugs" do
+ isReservedSlug "admin" `shouldEqual` true
+ isReservedSlug "register" `shouldEqual` true
+ isReservedSlug "" `shouldEqual` true
+ isReservedSlug "mtmn" `shouldEqual` false
- describe "Registrations" do
- it "validates slug format" do
- validSlugFormat "mtmn" `shouldEqual` true
- validSlugFormat "a-b-1" `shouldEqual` true
- validSlugFormat "Ab" `shouldEqual` false
- validSlugFormat "-x" `shouldEqual` false
- validSlugFormat "x-" `shouldEqual` false
- validSlugFormat "" `shouldEqual` false
- validSlugFormat "a b" `shouldEqual` false
-
- it "flags reserved slugs" do
- isReservedSlug "admin" `shouldEqual` true
- isReservedSlug "register" `shouldEqual` true
- isReservedSlug "" `shouldEqual` true
- isReservedSlug "mtmn" `shouldEqual` false
-
- it "insert/list/get/setStatus/slugTaken round-trip" do
- conn <- connect ":memory:"
- initRegistrations conn
- lock <- Avar.new unit
- insertRegistration conn lock
- { slug: "alice"
- , displayName: "Alice"
- , email: "a@x.com"
- , listenbrainzUser: Just "alice_lb"
- , lastfmUser: Nothing
- }
- pending <- listByStatus conn "pending"
- length pending `shouldEqual` 1
- taken <- slugTaken conn "alice"
- taken `shouldEqual` true
- free <- slugTaken conn "bob"
- free `shouldEqual` false
- case pending of
- [ r ] -> do
- r.slug `shouldEqual` "alice"
- r.displayName `shouldEqual` "Alice"
- r.listenbrainzUser `shouldEqual` Just "alice_lb"
- r.lastfmUser `shouldEqual` Nothing
- mReg <- getById conn r.id
- map _.slug mReg `shouldEqual` Just "alice"
- setStatus conn lock r.id "denied"
- pending2 <- listByStatus conn "pending"
- length pending2 `shouldEqual` 0
- takenAfterDeny <- slugTaken conn "alice"
- takenAfterDeny `shouldEqual` false
- _ ->
- fail "expected one pending registration"
+ it "insert/list/get/setStatus/slugTaken round-trip" do
+ conn <- connect ":memory:"
+ initRegistrations conn
+ lock <- Avar.new unit
+ insertRegistration conn lock
+ { slug: "alice"
+ , displayName: "Alice"
+ , email: "a@x.com"
+ , listenbrainzUser: Just "alice_lb"
+ , lastfmUser: Nothing
+ }
+ pending <- listByStatus conn "pending"
+ length pending `shouldEqual` 1
+ taken <- slugTaken conn "alice"
+ taken `shouldEqual` true
+ free <- slugTaken conn "bob"
+ free `shouldEqual` false
+ case pending of
+ [ r ] -> do
+ r.slug `shouldEqual` "alice"
+ r.displayName `shouldEqual` "Alice"
+ r.listenbrainzUser `shouldEqual` Just "alice_lb"
+ r.lastfmUser `shouldEqual` Nothing
+ mReg <- getById conn r.id
+ map _.slug mReg `shouldEqual` Just "alice"
+ setStatus conn lock r.id "denied"
+ pending2 <- listByStatus conn "pending"
+ length pending2 `shouldEqual` 0
+ takenAfterDeny <- slugTaken conn "alice"
+ takenAfterDeny `shouldEqual` false
+ _ ->
+ fail "expected one pending registration"
