commit 48121008f711ae381c19a665422f7dcd37fe092c
parent bf90a88810bdfd34f90bf86ebd55823f8ffa1fa3
Author: mtmn <miro@haravara.org>
Date: Fri, 17 Apr 2026 22:00:51 +0200
Merge branch 'feat/multi-user'
Diffstat:
15 files changed, 727 insertions(+), 373 deletions(-)
diff --git a/.env.example b/.env.example
@@ -1,15 +1,9 @@
-LISTENBRAINZ_USER=mtmn
-LASTFM_USER=
+DATABASE_PATH=/tmp
DISCOGS_TOKEN=
LASTFM_API_KEY=
-S3_BUCKET=corpus-covers
-S3_REGION=us-east-1
+S3_BUCKET=
+S3_REGION=
AWS_ACCESS_KEY_ID=
AWS_SECRET_ACCESS_KEY=
-AWS_S3_ADDRESSING_STYLE=path
-AWS_ENDPOINT_URL=http://localhost:8333
-INITIAL_SYNC=true
-DATABASE_FILE=/tmp/corpus.db
-COVER_CACHE_ENABLED=true
-BACKUP_ENABLED=true
-BACKUP_INTERVAL_HOURS=1
+AWS_S3_ADDRESSING_STYLE=
+AWS_ENDPOINT_URL=
diff --git a/docs/architecture.md b/docs/architecture.md
@@ -1,14 +1,14 @@
# Corpus Architecture
-Corpus is a personal music listening history dashboard and analytics service. It synchronizes scrobbles from ListenBrainz and Last.fm and provides a performant web interface for data exploration and statistics.
+Corpus is a self-hosted music listening history dashboard and analytics service. It supports multiple users, synchronizing scrobbles from ListenBrainz and Last.fm and providing a performant web interface for data exploration and statistics.
## System Components
### Web Server
The server is built with PureScript running on Node.js. It handles several core responsibilities:
- **HTTP API**: Serves the frontend, scrobble data (with filtering/pagination), and statistics.
-- **ListenBrainz Sync**: A background process that polls the ListenBrainz API every 60 seconds to fetch new scrobbles. Enabled when `LISTENBRAINZ_USER` is set.
-- **Last.fm Sync**: A background process that polls the Last.fm API every 60 seconds to fetch new scrobbles. Enabled when `LASTFM_USER` and `LASTFM_API_KEY` are set. Both syncs write to the same `scrobbles` table; duplicate timestamps are silently ignored.
+- **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).
@@ -19,7 +19,7 @@ A Single Page Application (SPA) built with [Elm](https://elm-lang.org).
- **Responsive UI**: Designed for both desktop and mobile viewing with a "retro-modern" aesthetic.
### Database
-Corpus uses **DuckDB** for its primary data storage.
+Corpus uses **DuckDB** for its primary data storage. Each user has their own database file.
- **Schema**:
- `scrobbles`: Stores the core listening history (timestamp, track, artist, album, MBIDs). The `listened_at` Unix timestamp is the primary key — scrobbles from ListenBrainz and Last.fm deduplicate naturally.
- `release_metadata`: Stores enriched metadata indexed by MusicBrainz Release ID (MBID).
@@ -29,6 +29,54 @@ Corpus uses **DuckDB** for its primary data 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.
+## Multi-User Support
+
+Corpus runs as a single server process serving multiple users. User configuration is defined in `users.dhall`, compiled to `users.json` at build time.
+
+### Routing
+- `/` and `/~<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
+
+### Configuration
+User configuration is split into two layers:
+
+1. **`users.dhall`** (build-time, non-sensitive): defines user slugs, source usernames, database filenames, and feature flags. Compiled to `users.json` at build time via `dhall-to-json`. The server reads this file at startup from the path in `CORPUS_CONFIG_FILE` (defaults to `users.json`).
+
+2. **Environment variables** (runtime, sensitive): shared API keys and S3 credentials are read from the environment at startup and applied to all users.
+
+Each user gets their own `UserContext` with an independent DuckDB connection, sync loop, and `isSyncing` flag. A shared `isSyncing` gate prevents reads during active syncs.
+
+## Configuration Reference
+
+### Environment Variables
+
+| Variable | Default | Purpose |
+|---|---|---|
+| `CORPUS_CONFIG_FILE` | `users.json` | Path to the compiled users config |
+| `DATABASE_PATH` | _(cwd)_ | Root directory for all user database files |
+| `LASTFM_API_KEY` | — | Last.fm API key (required if any user has `lastfmUser`) |
+| `DISCOGS_TOKEN` | — | Discogs token for cover/genre fallback |
+| `S3_BUCKET` | — | S3 bucket for cover art cache |
+| `S3_REGION` | `us-east-1` | S3 region |
+| `AWS_ACCESS_KEY_ID` | — | S3 credentials |
+| `AWS_SECRET_ACCESS_KEY` | — | S3 credentials |
+| `AWS_ENDPOINT_URL` | — | S3 endpoint (for S3-compatible storage) |
+| `AWS_S3_ADDRESSING_STYLE` | — | `virtual` or `path` |
+| `PORT` | `8000` | HTTP listen port |
+
+### users.dhall Fields
+
+| Field | Type | Purpose |
+|---|---|---|
+| `slug` | `Text` | URL slug (`""` for root user, `"filip"` for `/~filip`) |
+| `listenbrainzUser` | `Optional Text` | ListenBrainz username |
+| `lastfmUser` | `Optional Text` | Last.fm username |
+| `databaseFile` | `Text` | DuckDB filename (relative to `DATABASE_PATH`) |
+| `coverCacheEnabled` | `Bool` | Enable S3 cover art caching |
+| `backupEnabled` | `Bool` | Enable periodic S3 database backups |
+| `backupIntervalHours` | `Natural` | Backup frequency |
+| `initialSync` | `Bool` | Paginate full history on first startup |
+
## Data Flow
### Scrobble Synchronization
@@ -45,7 +93,7 @@ Both sync processes follow the same pattern: fetch the most recent page, insert
2. Insert new scrobbles; stop if an existing timestamp is found.
3. Paginate through subsequent pages using `totalPages` from the API response until fully caught up.
-Both processes run every 60 seconds. On subsequent syncs they stop at the first known timestamp, making incremental updates efficient.
+Both processes run every 60 seconds per user. On subsequent syncs they stop at the first known timestamp, making incremental updates efficient.
### Metadata Enrichment
1. Background task identifies MBIDs in `scrobbles` that are not in `release_metadata`.
@@ -66,17 +114,19 @@ When a cover is requested:
- **Language**: [PureScript](https://purescript.org) (server), [Elm](https://elm-lang.org) (frontend)
- **Runtime**: [Node.js](https://nodejs.org)
-- **Database**: [DuckDB](https://duckdb.org)
+- **Database**: [DuckDB](https://duckdb.org) (one file per user)
+- **Config**: [Dhall](https://dhall-lang.org) → JSON (compiled at build time)
- **Bundling**: [spago](https://github.com/purescript/spago) + [esbuild](https://esbuild.github.io/) (server), [elm make](https://guide.elm-lang.org/install/elm.html) (frontend)
- **Environment**: [Nix](https://nixos.org) for reproducible development shells and container builds
## Foreign Function Interface (FFI)
-Corpus relies on FFI to interact with the Node.js and browser ecosystems where native PureScript wrappers are unavailable or where direct JS access is required. Key FFI integrations include:
+Corpus relies on FFI to interact with the Node.js ecosystem where native PureScript wrappers are unavailable. Key FFI integrations:
-- **Database (`Db.js`)**: Provides a high-performance interface to the native `duckdb` library. It includes custom logic to handle BigInt conversions, ensuring database results are compatible with standard JSON serialization.
-- **Cloud Storage (`S3.js`)**: Leverages the official AWS SDK (`@aws-sdk/client-s3`) to manage cover art caching in S3-compatible storage.
-- **System Utilities (`Main.js`)**: Bridges PureScript with essential Node.js functionality, including environment variable management (`dotenv`) and raw buffer operations.
+- **Database (`Db.js`)**: Interface to the native `duckdb` library. Includes BigInt → Number conversion for JSON compatibility.
+- **Cloud Storage (`S3.js`)**: AWS SDK (`@aws-sdk/client-s3`) for cover art caching. Takes explicit config structs rather than reading `process.env`.
+- **System Utilities (`Main.js`)**: Bridges PureScript with Node.js — `dotenv` loading and request helpers.
+- **Config (`Config.js`)**: Reads and parses `users.json` from the path given by `CORPUS_CONFIG_FILE`.
## System Flow
@@ -91,20 +141,20 @@ graph TD
end
subgraph Corpus Server
- LBSync[ListenBrainz Sync]
- LFSync[Last.fm Sync]
- Enrich[Enrichment Task]
+ LBSync[ListenBrainz Sync\nper user]
+ LFSync[Last.fm Sync\nper user]
+ Enrich[Enrichment Task\nper user]
Proxy[Cover Proxy]
API[Web API]
end
subgraph Storage
- DB[(DuckDB)]
+ DB[(DuckDB\nper user)]
S3[[S3 Bucket]]
end
subgraph Frontend
- UI[Elm SPA]
+ UI[Elm SPA\n?user=slug]
end
%% Scrobble Sync Flow
diff --git a/flake.lock b/flake.lock
@@ -20,11 +20,11 @@
},
"nixpkgs": {
"locked": {
- "lastModified": 1775793324,
- "narHash": "sha256-omax7atcZbol+6HJ2RLpP+ZCFcPa5bZ65Hn71RufeWQ=",
+ "lastModified": 1776255774,
+ "narHash": "sha256-psVTpH6PK3q1htMJpmdz1hLF5pQgEshu7gQWgKO6t6Y=",
"owner": "NixOS",
"repo": "nixpkgs",
- "rev": "9d29d5f667d7467f98efc31881e824fa586c927e",
+ "rev": "566acc07c54dc807f91625bb286cb9b321b5f42a",
"type": "github"
},
"original": {
diff --git a/flake.nix b/flake.nix
@@ -140,6 +140,7 @@
git
purescript
elmPackages.elm
+ dhall-json
];
buildPhase = ''
@@ -165,12 +166,13 @@
cp -r ${elmDeps}/packages $HOME/.elm/0.19.1/
chmod -R u+w $HOME/.elm
+ dhall-to-json --file users.dhall > users.json
npm run build
'';
installPhase = ''
mkdir -p $out/lib/corpus
- cp -r server.js client.js package.json node_modules assets $out/lib/corpus/
+ cp -r server.js client.js users.json package.json node_modules assets $out/lib/corpus/
if [ -f .env ]; then
cp .env $out/lib/corpus/
else
@@ -219,6 +221,7 @@
awscli2
duckdb
esbuild
+ dhall-json
];
};
}
diff --git a/justfile b/justfile
@@ -8,6 +8,7 @@ setup:
# Build the project locally
build:
+ dhall-to-json --file users.dhall > users.json
npm run build
# Run the project locally
diff --git a/src/Client.elm b/src/Client.elm
@@ -18,7 +18,13 @@ import Url
port pushUrl : String -> Cmd msg
-main : Program String Model Msg
+type alias Flags =
+ { search : String
+ , userSlug : String
+ }
+
+
+main : Program Flags Model Msg
main =
Browser.element
{ init = init
@@ -98,14 +104,15 @@ type alias Model =
, customInput : String
, showCustomInput : Bool
, customError : Maybe String
+ , userSlug : String
}
-init : String -> ( Model, Cmd Msg )
-init searchString =
+init : Flags -> ( Model, Cmd Msg )
+init flags =
let
page =
- parsePageParam searchString
+ parsePageParam flags.search
offset =
max 0 ((page - 1) * 25)
@@ -128,9 +135,10 @@ init searchString =
, customInput = ""
, showCustomInput = False
, customError = Nothing
+ , userSlug = flags.userSlug
}
, Cmd.batch
- [ fetchListens 25 offset Nothing
+ [ fetchListens flags.userSlug 25 offset Nothing
, Task.perform GotTime Time.now
]
)
@@ -198,7 +206,7 @@ update msg model =
Tick time ->
if not model.loading then
( { model | currentTime = Just time, loading = True }
- , fetchListens model.limit model.offset model.activeFilter
+ , fetchListens model.userSlug model.limit model.offset model.activeFilter
)
else
@@ -254,7 +262,7 @@ update msg model =
in
( { model | offset = newOffset, loading = True }
, Cmd.batch
- [ fetchListens model.limit newOffset model.activeFilter
+ [ fetchListens model.userSlug model.limit newOffset model.activeFilter
, pushUrl ("?page=" ++ String.fromInt page)
]
)
@@ -269,7 +277,7 @@ update msg model =
in
( { model | offset = newOffset, loading = True }
, Cmd.batch
- [ fetchListens model.limit newOffset model.activeFilter
+ [ fetchListens model.userSlug model.limit newOffset model.activeFilter
, pushUrl ("?page=" ++ String.fromInt page)
]
)
@@ -279,7 +287,7 @@ update msg model =
, case tab of
StatsTab ->
if model.stats == Nothing then
- fetchStats model.statsPeriod
+ fetchStats model.userSlug model.statsPeriod
else
Cmd.none
@@ -296,7 +304,7 @@ update msg model =
, loadedSections = Set.empty
, showCustomInput = False
}
- , fetchStats period
+ , fetchStats model.userSlug period
)
OpenCustomInput ->
@@ -344,7 +352,7 @@ update msg model =
, showCustomInput = False
, customError = Nothing
}
- , fetchStats period
+ , fetchStats model.userSlug period
)
_ ->
@@ -357,7 +365,7 @@ update msg model =
in
( { model | activeFilter = filter, offset = 0, activeTab = ListensTab, loading = True }
, Cmd.batch
- [ fetchListens model.limit 0 filter
+ [ fetchListens model.userSlug model.limit 0 filter
, pushUrl "?page=1"
]
)
@@ -365,7 +373,7 @@ update msg model =
ClearFilter ->
( { model | activeFilter = Nothing, offset = 0, loading = True }
, Cmd.batch
- [ fetchListens model.limit 0 Nothing
+ [ fetchListens model.userSlug model.limit 0 Nothing
, pushUrl "?page=1"
]
)
@@ -380,7 +388,7 @@ update msg model =
( { model | expandedSections = Set.insert section model.expandedSections }, Cmd.none )
ShowAllSection section ->
- ( model, fetchSectionData model.statsPeriod section )
+ ( model, fetchSectionData model.userSlug model.statsPeriod section )
CollapseSection section ->
( { model
@@ -426,8 +434,8 @@ subscriptions _ =
-- HTTP
-fetchListens : Int -> Int -> Maybe ActiveFilter -> Cmd Msg
-fetchListens limit offset mFilter =
+fetchListens : String -> Int -> Int -> Maybe ActiveFilter -> Cmd Msg
+fetchListens userSlug limit offset mFilter =
let
filterParams =
case mFilter of
@@ -438,7 +446,7 @@ fetchListens limit offset mFilter =
"&filterField=" ++ field ++ "&filterValue=" ++ Url.percentEncode value
url =
- "/proxy?limit=" ++ String.fromInt limit ++ "&offset=" ++ String.fromInt offset ++ filterParams
+ "/proxy?user=" ++ userSlug ++ "&limit=" ++ String.fromInt limit ++ "&offset=" ++ String.fromInt offset ++ filterParams
in
Http.get
{ url = url
@@ -446,24 +454,24 @@ fetchListens limit offset mFilter =
}
-fetchStats : Period -> Cmd Msg
-fetchStats period =
+fetchStats : String -> Period -> Cmd Msg
+fetchStats userSlug period =
Http.get
- { url = statsUrl period Nothing
+ { url = statsUrl userSlug period Nothing
, expect = Http.expectJson GotStats statsDecoder
}
-fetchSectionData : Period -> String -> Cmd Msg
-fetchSectionData period section =
+fetchSectionData : String -> Period -> String -> Cmd Msg
+fetchSectionData userSlug period section =
Http.get
- { url = statsUrl period (Just section)
+ { url = statsUrl userSlug period (Just section)
, expect = Http.expectJson (GotSectionData section) (sectionEntriesDecoder section)
}
-statsUrl : Period -> Maybe String -> String
-statsUrl period mSection =
+statsUrl : String -> Period -> Maybe String -> String
+statsUrl userSlug period mSection =
let
periodPart =
case period of
@@ -471,10 +479,10 @@ statsUrl period mSection =
""
LastDays n ->
- "period=" ++ String.fromInt n
+ "&period=" ++ String.fromInt n
CustomRange from to ->
- "from=" ++ from ++ "&to=" ++ to
+ "&from=" ++ from ++ "&to=" ++ to
sectionPart =
case mSection of
@@ -482,25 +490,9 @@ statsUrl period mSection =
""
Just sec ->
- (if String.isEmpty periodPart then
- ""
-
- else
- "&"
- )
- ++ "section="
- ++ sec
-
- query =
- periodPart ++ sectionPart
+ "§ion=" ++ sec
in
- "/stats"
- ++ (if String.isEmpty query then
- ""
-
- else
- "?" ++ query
- )
+ "/stats?user=" ++ userSlug ++ periodPart ++ sectionPart
httpErrorToString : Http.Error -> String
@@ -631,7 +623,7 @@ view model =
""
)
)
- , href "/"
+ , href (if model.userSlug == "" then "/" else "/~" ++ model.userSlug)
]
[ text "listens" ]
, button
@@ -707,14 +699,14 @@ renderContent model =
ul [ Attr.id "tracks-container" ]
(List.indexedMap
(\idx listen ->
- renderListen model.currentTime model.failedCovers model.hoveredCover idx listen
+ renderListen model.userSlug model.currentTime model.failedCovers model.hoveredCover idx listen
)
model.listens
)
-renderListen : Maybe Time.Posix -> Set String -> Maybe Int -> Int -> Listen -> Html Msg
-renderListen currentTime failedCovers hoveredCover idx listen =
+renderListen : String -> Maybe Time.Posix -> Set String -> Maybe Int -> Int -> Listen -> Html Msg
+renderListen userSlug currentTime failedCovers hoveredCover idx listen =
let
artist =
Maybe.withDefault "" listen.artistName
@@ -731,7 +723,9 @@ renderListen currentTime failedCovers hoveredCover idx listen =
listen.releaseMbid
coverUrl =
- "/cover?artist="
+ "/cover?user="
+ ++ userSlug
+ ++ "&artist="
++ Url.percentEncode artist
++ "&release="
++ Url.percentEncode release
diff --git a/src/Config.js b/src/Config.js
@@ -0,0 +1,10 @@
+import { readFileSync } from "fs";
+
+export const loadConfigImpl = (path) => (onLeft) => (onRight) => () => {
+ try {
+ const json = readFileSync(path, { encoding: "utf8" });
+ onRight(JSON.parse(json))();
+ } catch (e) {
+ onLeft(e.message || String(e))();
+ }
+};
diff --git a/src/Config.purs b/src/Config.purs
@@ -0,0 +1,184 @@
+module Config where
+
+import Prelude
+
+import Data.Argonaut.Core (Json)
+import Data.Argonaut (decodeJson, (.:), (.:?))
+import Data.Either (Either(..))
+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 Effect.Aff (Aff, makeAff, nonCanceler)
+import Effect.Class (liftEffect)
+import Effect.Exception (error)
+import Node.Process (lookupEnv)
+
+type UserConfig =
+ { listenbrainzUser :: Maybe String
+ , lastfmUser :: Maybe String
+ , lastfmApiKey :: Maybe String
+ , discogsToken :: Maybe String
+ , databaseFile :: String
+ , s3Bucket :: Maybe String
+ , s3Region :: String
+ , awsAccessKeyId :: Maybe String
+ , awsSecretAccessKey :: Maybe String
+ , awsEndpointUrl :: Maybe String
+ , awsS3AddressingStyle :: Maybe String
+ , coverCacheEnabled :: Boolean
+ , backupEnabled :: Boolean
+ , backupIntervalHours :: Int
+ , initialSync :: Boolean
+ }
+
+type UserEntry =
+ { slug :: String
+ , config :: UserConfig
+ }
+
+type AppConfig =
+ { port :: Int
+ , users :: Array UserEntry
+ }
+
+type S3Config =
+ { bucket :: Maybe String
+ , region :: String
+ , accessKeyId :: Maybe String
+ , secretAccessKey :: Maybe String
+ , endpointUrl :: Maybe String
+ , addressingStyle :: Maybe String
+ }
+
+s3ConfigFromUser :: UserConfig -> S3Config
+s3ConfigFromUser cfg =
+ { bucket: cfg.s3Bucket
+ , region: cfg.s3Region
+ , accessKeyId: cfg.awsAccessKeyId
+ , secretAccessKey: cfg.awsSecretAccessKey
+ , endpointUrl: cfg.awsEndpointUrl
+ , addressingStyle: cfg.awsS3AddressingStyle
+ }
+
+foreign import loadConfigImpl
+ :: String
+ -> (String -> Effect Unit)
+ -> (Json -> Effect Unit)
+ -> Effect Unit
+
+loadConfig :: String -> Aff AppConfig
+loadConfig path = do
+ json <- makeAff \cb ->
+ loadConfigImpl path
+ (\msg -> cb (Left (error msg)))
+ (\j -> cb (Right j))
+ *> pure nonCanceler
+ rawUsers <- case decodeUsersJson json of
+ Left msg -> makeAff \cb -> cb (Left (error msg)) *> pure nonCanceler
+ Right users -> pure users
+ portStr <- liftEffect $ lookupEnv "PORT"
+ lastfmApiKey <- liftEffect $ lookupEnv "LASTFM_API_KEY"
+ discogsToken <- liftEffect $ lookupEnv "DISCOGS_TOKEN"
+ s3Bucket <- liftEffect $ lookupEnv "S3_BUCKET"
+ s3Region <- liftEffect $ map (fromMaybe "us-east-1") $ lookupEnv "S3_REGION"
+ awsAccessKeyId <- liftEffect $ lookupEnv "AWS_ACCESS_KEY_ID"
+ awsSecretAccessKey <- liftEffect $ lookupEnv "AWS_SECRET_ACCESS_KEY"
+ awsEndpointUrl <- liftEffect $ lookupEnv "AWS_ENDPOINT_URL"
+ awsS3AddressingStyle <- liftEffect $ lookupEnv "AWS_S3_ADDRESSING_STYLE"
+ databasePath <- liftEffect $ lookupEnv "DATABASE_PATH"
+ let
+ resolvePath file = case databasePath of
+ Nothing -> file
+ Just dir -> dir <> "/" <> file
+ fillCreds cfg = cfg
+ { lastfmApiKey = lastfmApiKey
+ , discogsToken = discogsToken
+ , s3Bucket = s3Bucket
+ , s3Region = s3Region
+ , awsAccessKeyId = awsAccessKeyId
+ , awsSecretAccessKey = awsSecretAccessKey
+ , awsEndpointUrl = awsEndpointUrl
+ , awsS3AddressingStyle = awsS3AddressingStyle
+ , databaseFile = resolvePath cfg.databaseFile
+ }
+ let
+ port = fromMaybe 8000 (portStr >>= Data.Int.fromString)
+ fullConfig = { port, users: map (\u -> u { config = fillCreds u.config }) rawUsers }
+ case validateConfig fullConfig of
+ Left msg -> makeAff \cb -> cb (Left (error msg)) *> pure nonCanceler
+ Right cfg -> pure cfg
+
+validateConfig :: AppConfig -> Either String AppConfig
+validateConfig cfg = do
+ _ <- traverse validateUserEntry cfg.users
+ pure cfg
+
+validateUserEntry :: UserEntry -> Either String UserEntry
+validateUserEntry entry =
+ let
+ c = entry.config
+ label = if entry.slug == "" then "root" else entry.slug
+ lfmMissing =
+ 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.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)
+
+mapLeft :: forall a b c. (a -> c) -> Either a b -> Either c b
+mapLeft f (Left a) = Left (f a)
+mapLeft _ (Right b) = Right b
+
+decodeUsersJson :: Json -> Either String (Array UserEntry)
+decodeUsersJson json = do
+ obj <- mapLeft show $ decodeJson json
+ usersArr <- mapLeft show (obj .: "users" :: Either _ (Array Json))
+ traverse decodeUserEntry usersArr
+
+decodeUserEntry :: Json -> Either String UserEntry
+decodeUserEntry json = do
+ obj <- mapLeft show $ decodeJson json
+ slug <- mapLeft show $ obj .: "slug"
+ configJson <- mapLeft show (obj .: "config" :: Either _ Json)
+ config <- decodeUserConfig configJson
+ pure { slug, config }
+
+-- Decodes only the non-sensitive, per-user fields from users.json.
+-- Shared credentials are injected from environment variables in loadConfig.
+decodeUserConfig :: Json -> Either String UserConfig
+decodeUserConfig json = do
+ obj <- mapLeft show $ decodeJson json
+ listenbrainzUser <- mapLeft show $ obj .:? "listenbrainzUser"
+ lastfmUser <- mapLeft show $ obj .:? "lastfmUser"
+ databaseFile <- mapLeft show $ obj .: "databaseFile"
+ coverCacheEnabled <- mapLeft show $ obj .: "coverCacheEnabled"
+ backupEnabled <- mapLeft show $ obj .: "backupEnabled"
+ backupIntervalHours <- mapLeft show $ obj .: "backupIntervalHours"
+ initialSync <- mapLeft show $ obj .: "initialSync"
+ pure
+ { listenbrainzUser
+ , lastfmUser
+ , lastfmApiKey: Nothing
+ , discogsToken: Nothing
+ , databaseFile
+ , s3Bucket: Nothing
+ , s3Region: "us-east-1"
+ , awsAccessKeyId: Nothing
+ , awsSecretAccessKey: Nothing
+ , awsEndpointUrl: Nothing
+ , awsS3AddressingStyle: Nothing
+ , coverCacheEnabled
+ , backupEnabled
+ , backupIntervalHours
+ , initialSync
+ }
diff --git a/src/Db.purs b/src/Db.purs
@@ -23,6 +23,7 @@ import Data.Int (fromString)
import Data.String (Pattern(..), split, stripSuffix)
import Control.Monad.Rec.Class (forever)
import Node.FS.Aff as FSA
+import Config (S3Config)
import S3 as S3
import Log as Log
@@ -67,8 +68,8 @@ dbBaseName path =
in
fromMaybe name (stripSuffix (Pattern ".db") name)
-performBackup :: Connection -> String -> Aff Unit
-performBackup conn dbFile = do
+performBackup :: Connection -> String -> S3Config -> Aff Unit
+performBackup conn dbFile s3cfg = do
checkpoint conn
dt <- liftEffect nowDateTime
let
@@ -77,13 +78,13 @@ performBackup conn dbFile = do
Left _ -> "unknown"
let key = "backups/" <> dbBaseName dbFile <> "-" <> ts <> ".db"
buf <- FSA.readFile dbFile
- S3.uploadToS3 key buf "application/octet-stream"
+ S3.uploadToS3 s3cfg key buf "application/octet-stream"
Log.info $ "Backup uploaded to S3: " <> key
-backupDb :: Connection -> String -> Number -> Aff Unit
-backupDb conn dbFile intervalMs = forever do
+backupDb :: Connection -> String -> S3Config -> Number -> Aff Unit
+backupDb conn dbFile s3cfg intervalMs = forever do
delay (Milliseconds intervalMs)
- result <- try $ performBackup conn dbFile
+ result <- try $ performBackup conn dbFile s3cfg
case result of
Left err -> Log.error $ "Backup failed: " <> message err
Right _ -> pure unit
diff --git a/src/Main.purs b/src/Main.purs
@@ -2,6 +2,7 @@ module Main where
import Prelude
+import Config (AppConfig, UserConfig, UserEntry, loadConfig, s3ConfigFromUser)
import Effect (Effect)
import Effect.Class (liftEffect)
import Log as Log
@@ -27,7 +28,6 @@ import Effect.Ref as Ref
import Effect.Ref (Ref)
import Unsafe.Coerce (unsafeCoerce)
import Node.FS.Aff as FSA
-import Node.Process (getEnv)
import Fetch (fetch, Method(GET), lookup)
import Fetch.Argonaut.Json (fromJson)
import Data.Maybe (Maybe(..), fromMaybe)
@@ -35,15 +35,17 @@ import JSURI (encodeURIComponent)
import Foreign.Object as Object
import Data.Argonaut (decodeJson, encodeJson, parseJson)
import Data.Argonaut.Core (Json, toObject, toArray, toString, stringify)
-import Data.Array ((!!), length, uncons, mapMaybe)
+import Data.Array ((!!), length, uncons, mapMaybe, find)
import Data.Tuple (Tuple(..))
import Data.Foldable (for_)
+import Data.Traversable (traverse)
import Db (Connection, connect, initDb, upsertScrobble, getScrobbles, checkExists, getOldestTs, run, initReleaseMetadata, getUnenrichedMbids, getEmptyGenreMbids, getArtistReleaseByMbid, upsertReleaseMetadata, touchGenreCheckedAt, getStats, ping, backupDb)
import Types (Listen(..), ListenBrainzResponse(..), MbidMapping(..), Payload(..), TrackMetadata(..))
import Control.Monad.Rec.Class (forever)
import Data.Time.Duration (Milliseconds(..))
import Data.Int (fromString, toNumber)
-import Data.String (Pattern(..))
+import Data.String (Pattern(..), stripPrefix)
+import Node.Process (lookupEnv)
import Data.String.Common (split) as String
import Data.String.Regex (replace, parseFlags)
import Data.String.Regex.Unsafe (unsafeRegex)
@@ -57,6 +59,13 @@ import Web.URL.URLSearchParams as URLSearchParams
type Request = IncomingMessage IMServer
type Response = ServerResponse
+type UserContext =
+ { conn :: Connection
+ , isSyncing :: Ref Boolean
+ , config :: UserConfig
+ , slug :: String
+ }
+
listenBrainzUrl :: String -> String
listenBrainzUrl username = "https://api.listenbrainz.org/1/user/" <> username <> "/listens"
@@ -329,8 +338,9 @@ lfSyncLoop conn apiKey lfmUser isSyncing initialSyncEnabled = forever do
delay (Milliseconds 60000.0)
lfSyncOnce conn apiKey lfmUser isSyncing initialSyncEnabled
-indexHtml :: String
-indexHtml =
+-- Build the per-user index HTML, inlining the slug for the Elm app.
+indexHtml :: String -> String
+indexHtml userSlug =
"""<!DOCTYPE html>
<html lang="en">
<head>
@@ -761,20 +771,25 @@ indexHtml =
<div id="app"></div>
<script src="/client.js"></script>
<script>
+ var userSlug = '""" <> userSlug <>
+ """';
var app = Elm.Client.init({
node: document.getElementById('app'),
- flags: window.location.search
+ flags: { search: window.location.search, userSlug: userSlug }
});
app.ports.pushUrl.subscribe(function(url) {
- history.pushState({}, '', url);
+ var prefix = userSlug ? '/~' + userSlug : '';
+ history.pushState({}, '', prefix + url);
});
</script>
</body>
</html>"""
-- Request handler
-handleRequest :: Connection -> Ref Boolean -> Boolean -> Request -> Response -> Effect Unit
-handleRequest db isSyncing coverCacheEnabled req res = do
+-- API endpoints (/proxy, /stats, /cover, /healthz) select the user via ?user=<slug>.
+-- Index pages are served at / (root user) and /~<slug> (named users).
+handleRequest :: Array UserContext -> Request -> Response -> Effect Unit
+handleRequest contexts req res = do
let method = IM.method req
let rawUrl = IM.url req
case URL.fromRelative rawUrl "http://localhost" of
@@ -782,26 +797,37 @@ handleRequest db isSyncing coverCacheEnabled req res = do
Just url -> do
let path = URL.pathname url
Log.info $ method <> " " <> rawUrl
-
case path of
- "/" -> serveIndex res
- "/healthz" -> serveHealthz db isSyncing res
- "/proxy" -> serveProxy db isSyncing url res
- "/cover" -> serveCover coverCacheEnabled isSyncing url res
- "/stats" -> serveStats db isSyncing url res
"/client.js" -> serveClientJs res
"/favicon.png" -> serveAsset "image/png" "assets/favicon.png" res
- _ -> do
- Log.warn $ "Path not found: " <> path
+ "/" -> serveIndex "" res
+ "/proxy" -> withUser url \ctx -> serveProxy ctx.conn ctx.isSyncing url res
+ "/stats" -> withUser url \ctx -> serveStats ctx.conn ctx.isSyncing url res
+ "/cover" -> withUser url \ctx -> serveCover ctx.config ctx.isSyncing url res
+ "/healthz" -> withUser url \ctx -> serveHealthz ctx.conn ctx.isSyncing res
+ _ -> case stripPrefix (Pattern "/~") path of
+ Just slug -> serveIndex slug res
+ Nothing -> do
+ Log.warn $ "Path not found: " <> path
+ serveNotFound res
+ where
+ withUser url f =
+ let
+ slug = fromMaybe "" (getQueryParam "user" url)
+ in
+ case find (\c -> c.slug == slug) contexts of
+ Nothing -> do
+ Log.warn $ "Unknown user: " <> show slug
serveNotFound res
+ Just ctx -> f ctx
-serveIndex :: Response -> Effect Unit
-serveIndex res = do
+serveIndex :: String -> Response -> Effect Unit
+serveIndex slug res = do
setHeader "Content-Type" "text/html" (toOutgoingMessage res)
setHeader "Access-Control-Allow-Origin" "*" (toOutgoingMessage res)
setStatusCode 200 res
let w = toWriteable (toOutgoingMessage res)
- void $ writeString w UTF8 indexHtml
+ void $ writeString w UTF8 (indexHtml slug)
end w
serveClientJs :: Response -> Effect Unit
@@ -831,52 +857,48 @@ sanitizeKey str =
in
replace re2 "_" (replace re1 "_" str)
-serveCover :: Boolean -> Ref Boolean -> URL -> Response -> Effect Unit
-serveCover coverCacheEnabled isSyncing url res = do
+serveCover :: UserConfig -> Ref Boolean -> URL -> Response -> Effect Unit
+serveCover cfg isSyncing url res = do
launchAff_ do
yieldToSync isSyncing
let mbid = fromMaybe "" (getQueryParam "mbid" url)
let artistStr = fromMaybe "" (getQueryParam "artist" url)
let releaseStr = fromMaybe "" (getQueryParam "release" url)
-
- -- Strategy:
- -- 1. If MBID exists, try CAA (S3 first, then Fetch)
- -- 2. If CAA fails or no MBID, try Last.fm (S3 first, then Fetch)
- -- 3. If Last.fm fails, try Discogs (S3 first, then Fetch)
+ let s3cfg = s3ConfigFromUser cfg
if mbid /= "" then do
let safeMbid = sanitizeKey mbid
let s3Key = "covers/caa/" <> safeMbid <> ".jpg"
- cached <- checkS3 s3Key
+ cached <- checkS3 s3cfg s3Key
if cached then do
Log.info $ "Serving CAA cover from S3: " <> s3Key
- serveS3 s3Key res
+ serveS3 s3cfg s3Key res
else do
Log.info $ "Fetching CAA cover: " <> mbid
let caaUrl = "https://coverartarchive.org/release/" <> mbid <> "/front-250"
- success <- tryProxyAndCache caaUrl s3Key res
+ success <- tryProxyAndCache s3cfg caaUrl s3Key res
unless success $ do
Log.info $ "CAA cover not found for " <> mbid <> ", falling back to Last.fm"
- tryLastfm artistStr releaseStr res
+ tryLastfm s3cfg artistStr releaseStr res
else do
Log.info $ "No MBID provided, trying Last.fm for: " <> artistStr <> " - " <> releaseStr
- tryLastfm artistStr releaseStr res
+ tryLastfm s3cfg artistStr releaseStr res
where
- checkS3 s3Key
- | not coverCacheEnabled = pure false
+ checkS3 s3cfg s3Key
+ | not cfg.coverCacheEnabled = pure false
| otherwise = do
- result <- try $ existsInS3 s3Key
+ result <- try $ existsInS3 s3cfg s3Key
pure $ case result of
Right b -> b
Left _ -> false
- serveS3 s3Key response = liftEffect $ do
+ serveS3 s3cfg s3Key response = liftEffect $ do
setStatusCode 302 response
- setHeader "Location" (getS3Url s3Key) (toOutgoingMessage response)
+ setHeader "Location" (getS3Url s3cfg s3Key) (toOutgoingMessage response)
end (toWriteable (toOutgoingMessage response))
- tryProxyAndCache urlStr s3Key response = do
+ tryProxyAndCache s3cfg urlStr s3Key response = do
fetchResult <- try $ fetch urlStr { method: GET }
case fetchResult of
Right fr | fr.status == 200 -> do
@@ -892,103 +914,98 @@ serveCover coverCacheEnabled isSyncing url res = do
void $ write writer nativeBuf
end writer
- -- Cache to S3 in background
- when coverCacheEnabled $ void $ forkAff $ do
- uploadResult <- try $ uploadToS3 s3Key (unsafeCoerce buf) contentType
+ when cfg.coverCacheEnabled $ void $ forkAff $ do
+ uploadResult <- try $ uploadToS3 s3cfg s3Key (unsafeCoerce buf) contentType
case uploadResult of
Right _ -> Log.info $ "Cached to S3: " <> s3Key
Left err -> Log.error $ "S3 upload failed: " <> Exception.message err
pure true
_ -> pure false
- tryLastfm artist release response
+ tryLastfm s3cfg artist release response
| artist == "" || release == "" = do
- Log.warn $ "Missing artist or release for Last.fm fallback"
+ Log.warn "Missing artist or release for Last.fm fallback"
liftEffect $ serveNotFound response
| otherwise = do
let safeArtist = sanitizeKey artist
let safeRelease = sanitizeKey release
let s3Key = "covers/lastfm/" <> safeArtist <> "-" <> safeRelease <> ".jpg"
- cached <- checkS3 s3Key
+ cached <- checkS3 s3cfg s3Key
if cached then do
Log.info $ "Serving Last.fm cover from S3: " <> s3Key
- serveS3 s3Key response
- else do
- env <- liftEffect getEnv
- case Object.lookup "LASTFM_API_KEY" env of
- Nothing -> do
- Log.warn "LASTFM_API_KEY missing, falling back to Discogs"
- tryDiscogs artist release response
- Just k -> do
- let searchUrl = "https://ws.audioscrobbler.com/2.0/?method=album.getinfo&api_key=" <> k <> "&artist=" <> (fromMaybe "" $ encodeURIComponent artist) <> "&album=" <> (fromMaybe "" $ encodeURIComponent release) <> "&format=json"
- Log.info $ "Searching Last.fm for: " <> artist <> " - " <> release
- result <- try $ fetch searchUrl { method: GET }
- case result of
- Right fetchRes | fetchRes.status == 200 -> do
- json <- fromJson fetchRes.json
- let
- coverUrl = do
- obj <- toObject json
- album <- Object.lookup "album" obj >>= toObject
- images <- Object.lookup "image" album >>= toArray
- imageObj <- images !! 2 >>= toObject
- u <- Object.lookup "#text" imageObj >>= toString
- if u == "" then Nothing else Just u
- case coverUrl of
- Just urlStr -> do
- Log.info $ "Found Last.fm cover: " <> urlStr
- success <- tryProxyAndCache urlStr s3Key response
- unless success $ do
- Log.info "Last.fm image proxy failed, falling back to Discogs"
- tryDiscogs artist release response
- Nothing -> do
- Log.info "No cover found on Last.fm, falling back to Discogs"
- tryDiscogs artist release response
- _ -> do
- Log.info "Last.fm API request failed, falling back to Discogs"
- tryDiscogs artist release response
-
- tryDiscogs artist release response = do
+ serveS3 s3cfg s3Key response
+ else case cfg.lastfmApiKey of
+ Nothing -> do
+ Log.warn "lastfmApiKey not configured, falling back to Discogs"
+ tryDiscogs s3cfg artist release response
+ Just k -> do
+ let searchUrl = "https://ws.audioscrobbler.com/2.0/?method=album.getinfo&api_key=" <> k <> "&artist=" <> (fromMaybe "" $ encodeURIComponent artist) <> "&album=" <> (fromMaybe "" $ encodeURIComponent release) <> "&format=json"
+ Log.info $ "Searching Last.fm for: " <> artist <> " - " <> release
+ result <- try $ fetch searchUrl { method: GET }
+ case result of
+ Right fetchRes | fetchRes.status == 200 -> do
+ json <- fromJson fetchRes.json
+ let
+ coverUrl = do
+ obj <- toObject json
+ album <- Object.lookup "album" obj >>= toObject
+ images <- Object.lookup "image" album >>= toArray
+ imageObj <- images !! 2 >>= toObject
+ u <- Object.lookup "#text" imageObj >>= toString
+ if u == "" then Nothing else Just u
+ case coverUrl of
+ Just urlStr -> do
+ Log.info $ "Found Last.fm cover: " <> urlStr
+ success <- tryProxyAndCache s3cfg urlStr s3Key response
+ unless success $ do
+ Log.info "Last.fm image proxy failed, falling back to Discogs"
+ tryDiscogs s3cfg artist release response
+ Nothing -> do
+ Log.info "No cover found on Last.fm, falling back to Discogs"
+ tryDiscogs s3cfg artist release response
+ _ -> do
+ Log.info "Last.fm API request failed, falling back to Discogs"
+ tryDiscogs s3cfg artist release response
+
+ tryDiscogs s3cfg artist release response = do
let safeArtist = sanitizeKey artist
let safeRelease = sanitizeKey release
let s3Key = "covers/discogs/" <> safeArtist <> "-" <> safeRelease <> ".jpg"
- cached <- checkS3 s3Key
+ cached <- checkS3 s3cfg s3Key
if cached then do
Log.info $ "Serving Discogs cover from S3: " <> s3Key
- serveS3 s3Key response
- else do
- env <- liftEffect getEnv
- case Object.lookup "DISCOGS_TOKEN" env of
- Nothing -> do
- Log.warn "DISCOGS_TOKEN missing, cannot fallback further"
- liftEffect $ serveNotFound response
- Just t -> do
- let queryStr = artist <> " " <> release
- let searchUrl = "https://api.discogs.com/database/search?q=" <> (fromMaybe "" $ encodeURIComponent queryStr) <> "&type=release&per_page=1&token=" <> t
- Log.info $ "Searching Discogs for: " <> queryStr
- result <- try $ fetch searchUrl { method: GET, headers: { "User-Agent": "ScrobblerPureScript/1.0" } }
- case result of
- Right fetchRes | fetchRes.status == 200 -> do
- json <- fromJson fetchRes.json
- let
- coverUrl = do
- obj <- toObject json
- results <- Object.lookup "results" obj >>= toArray
- firstResult <- results !! 0 >>= toObject
- Object.lookup "cover_image" firstResult >>= toString
- case coverUrl of
- Just urlStr -> do
- Log.info $ "Found Discogs cover: " <> urlStr
- success <- tryProxyAndCache urlStr s3Key response
- unless success $ do
- Log.info "Discogs image proxy failed"
- liftEffect $ serveNotFound response
- Nothing -> do
- Log.info "No cover found on Discogs"
+ serveS3 s3cfg s3Key response
+ else case cfg.discogsToken of
+ Nothing -> do
+ Log.warn "discogsToken not configured, cannot fallback further"
+ liftEffect $ serveNotFound response
+ Just t -> do
+ let queryStr = artist <> " " <> release
+ let searchUrl = "https://api.discogs.com/database/search?q=" <> (fromMaybe "" $ encodeURIComponent queryStr) <> "&type=release&per_page=1&token=" <> t
+ Log.info $ "Searching Discogs for: " <> queryStr
+ result <- try $ fetch searchUrl { method: GET, headers: { "User-Agent": "ScrobblerPureScript/1.0" } }
+ case result of
+ Right fetchRes | fetchRes.status == 200 -> do
+ json <- fromJson fetchRes.json
+ let
+ coverUrl = do
+ obj <- toObject json
+ results <- Object.lookup "results" obj >>= toArray
+ firstResult <- results !! 0 >>= toObject
+ Object.lookup "cover_image" firstResult >>= toString
+ case coverUrl of
+ Just urlStr -> do
+ Log.info $ "Found Discogs cover: " <> urlStr
+ success <- tryProxyAndCache s3cfg urlStr s3Key response
+ unless success $ do
+ Log.info "Discogs image proxy failed"
liftEffect $ serveNotFound response
- _ -> do
- Log.info "Discogs API request failed"
- liftEffect $ serveNotFound response
+ Nothing -> do
+ Log.info "No cover found on Discogs"
+ liftEffect $ serveNotFound response
+ _ -> do
+ Log.info "Discogs API request failed"
+ liftEffect $ serveNotFound response
serveProxy :: Connection -> Ref Boolean -> URL -> Response -> Effect Unit
serveProxy db isSyncing url res = do
@@ -1115,7 +1132,6 @@ fetchMusicBrainzRelease mbid = do
Nothing -> Nothing
Log.info $ "Enriched " <> mbid <> ": genre=" <> show genre <> " label=" <> show label <> " year=" <> show year
- -- Warn if all fields are empty
when (genre == Nothing && label == Nothing && year == Nothing)
$ Log.warn
$ "All fields empty for " <> mbid <> " - possible parsing issue or missing data"
@@ -1128,79 +1144,74 @@ fetchMusicBrainzRelease mbid = do
Log.warn $ "MusicBrainz " <> show fr.status <> " for " <> mbid <> ", will retry"
pure Nothing
-fetchLastfmGenre :: String -> String -> Aff (Maybe String)
-fetchLastfmGenre artist release = do
- env <- liftEffect getEnv
- case Object.lookup "LASTFM_API_KEY" env of
- Nothing -> do
- Log.warn "LASTFM_API_KEY missing for genre fallback"
- pure Nothing
- Just k -> do
- let searchUrl = "https://ws.audioscrobbler.com/2.0/?method=album.getinfo&api_key=" <> k <> "&artist=" <> (fromMaybe "" $ encodeURIComponent artist) <> "&album=" <> (fromMaybe "" $ encodeURIComponent release) <> "&format=json"
- Log.info $ "Fetching Last.fm genre for: " <> artist <> " - " <> release
- result <- try $ fetch searchUrl { method: GET }
- case result of
- Right fetchRes | fetchRes.status == 200 -> do
- jsonResult <- try $ fromJson fetchRes.json
- case jsonResult of
- Left err -> do
- Log.error $ "Last.fm genre JSON error: " <> Exception.message err
- pure Nothing
- Right json -> do
- let
- genre = do
- obj <- toObject json
- album <- Object.lookup "album" obj >>= toObject
- tags <- Object.lookup "tags" album >>= toObject
- tagArray <- Object.lookup "tag" tags >>= toArray
- firstTag <- tagArray !! 0 >>= toObject
- Object.lookup "name" firstTag >>= toString
- pure genre
- _ -> do
- Log.warn "Last.fm genre API request failed"
+-- Explicit apiKey parameter — no env read.
+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&api_key=" <> k <> "&artist=" <> (fromMaybe "" $ encodeURIComponent artist) <> "&album=" <> (fromMaybe "" $ encodeURIComponent release) <> "&format=json"
+ Log.info $ "Fetching Last.fm genre for: " <> artist <> " - " <> release
+ result <- try $ fetch searchUrl { method: GET }
+ case result of
+ Right fetchRes | fetchRes.status == 200 -> do
+ jsonResult <- try $ fromJson fetchRes.json
+ case jsonResult of
+ Left err -> do
+ Log.error $ "Last.fm genre JSON error: " <> Exception.message err
pure Nothing
-
-fetchDiscogsGenre :: String -> String -> Aff (Maybe String)
-fetchDiscogsGenre artist release = do
- env <- liftEffect getEnv
- case Object.lookup "DISCOGS_TOKEN" env of
- Nothing -> do
- Log.warn "DISCOGS_TOKEN missing for genre fallback"
+ Right json -> do
+ let
+ genre = do
+ obj <- toObject json
+ album <- Object.lookup "album" obj >>= toObject
+ tags <- Object.lookup "tags" album >>= toObject
+ tagArray <- Object.lookup "tag" tags >>= toArray
+ firstTag <- tagArray !! 0 >>= toObject
+ Object.lookup "name" firstTag >>= toString
+ pure genre
+ _ -> do
+ Log.warn "Last.fm genre API request failed"
pure Nothing
- Just t -> do
- let queryStr = artist <> " " <> release
- let searchUrl = "https://api.discogs.com/database/search?q=" <> (fromMaybe "" $ encodeURIComponent queryStr) <> "&type=release&per_page=1&token=" <> t
- Log.info $ "Fetching Discogs genre for: " <> queryStr
- result <- try $ fetch searchUrl { method: GET, headers: { "User-Agent": "ScrobblerPureScript/1.0" } }
- case result of
- Right fetchRes | fetchRes.status == 200 -> do
- jsonResult <- try $ fromJson fetchRes.json
- case jsonResult of
- Left err -> do
- Log.error $ "Discogs genre JSON error: " <> Exception.message err
- pure Nothing
- Right json -> do
- let
- genre = do
- obj <- toObject json
- results <- Object.lookup "results" obj >>= toArray
- firstResult <- results !! 0 >>= toObject
- genres <- Object.lookup "genres" firstResult >>= toArray
- genres !! 0 >>= toString
- pure genre
- _ -> do
- Log.warn "Discogs genre API request failed"
+
+-- Explicit token parameter — no env read.
+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&token=" <> t
+ Log.info $ "Fetching Discogs genre for: " <> queryStr
+ result <- try $ fetch searchUrl { method: GET, headers: { "User-Agent": "ScrobblerPureScript/1.0" } }
+ case result of
+ Right fetchRes | fetchRes.status == 200 -> do
+ jsonResult <- try $ fromJson fetchRes.json
+ case jsonResult of
+ Left err -> do
+ Log.error $ "Discogs genre JSON error: " <> Exception.message err
pure Nothing
+ Right json -> do
+ let
+ genre = do
+ obj <- toObject json
+ results <- Object.lookup "results" obj >>= toArray
+ firstResult <- results !! 0 >>= toObject
+ genres <- Object.lookup "genres" firstResult >>= toArray
+ genres !! 0 >>= toString
+ pure genre
+ _ -> do
+ Log.warn "Discogs genre API request failed"
+ pure Nothing
yieldToSync :: Ref Boolean -> Aff Unit
yieldToSync isSyncing = do
syncing <- liftEffect $ Ref.read isSyncing
when syncing $ delay (Milliseconds 200.0) *> yieldToSync isSyncing
-enrichMetadata :: Connection -> Ref Boolean -> Aff Unit
-enrichMetadata conn isSyncing = forever do
+enrichMetadata :: Connection -> Ref Boolean -> UserConfig -> Aff Unit
+enrichMetadata conn isSyncing cfg = forever do
yieldToSync isSyncing
- -- Get both unenriched and empty genre MBIDs
unenrichedMbids <- getUnenrichedMbids conn 10
emptyGenreMbids <- getEmptyGenreMbids conn 10
let allMbids = unenrichedMbids <> emptyGenreMbids
@@ -1217,20 +1228,15 @@ enrichMetadata conn isSyncing = forever do
Left err -> Log.error $ "Enrichment error: " <> Exception.message err
Right Nothing -> pure unit
Right (Just mbdata) -> do
- -- If genre is empty, try fallback sources
if mbdata.genre == Nothing then do
artistRelease <- getArtistReleaseByMbid conn mbid
case artistRelease of
Just { artist, release } -> do
- -- Try Last.fm first
- lastfmGenre <- fetchLastfmGenre artist release
+ lastfmGenre <- fetchLastfmGenre cfg.lastfmApiKey artist release
finalGenre <- case lastfmGenre of
Just _ -> pure lastfmGenre
- Nothing -> do
- -- Try Discogs as final fallback
- fetchDiscogsGenre artist release
+ Nothing -> fetchDiscogsGenre cfg.discogsToken artist release
- -- Update with the best genre we found
let finalMbdata = mbdata { genre = finalGenre }
upsertReleaseMetadata conn mbid finalMbdata.genre finalMbdata.label finalMbdata.year
@@ -1244,71 +1250,65 @@ enrichMetadata conn isSyncing = forever do
upsertReleaseMetadata conn mbid mbdata.genre mbdata.label mbdata.year
touchGenreCheckedAt conn mbid
else do
- -- Genre found in MusicBrainz, just save as usual
upsertReleaseMetadata conn mbid mbdata.genre mbdata.label mbdata.year
-startServer :: Int -> String -> String -> Boolean -> Number -> Boolean -> Boolean -> Effect Unit
-startServer port dbFile username backupEnabled backupIntervalMs coverCacheEnabled initialSyncEnabled = launchAff_ do
- conn <- connect dbFile
+-- Initialise one user: connect DB, start sync loops, return a UserContext.
+startUser :: UserEntry -> Aff UserContext
+startUser { slug, config } = do
+ Log.info $ "Starting user: " <> if slug == "" then "(root)" else slug
+ conn <- connect config.databaseFile
initDb conn
initReleaseMetadata conn
isSyncing <- liftEffect $ Ref.new false
- env <- liftEffect getEnv
- let
- lfmUser = getEnvStr env "LASTFM_USER" ""
- lfmApiKey = getEnvStr env "LASTFM_API_KEY" ""
- lbEnabled = username /= ""
- lfEnabled = lfmUser /= "" && lfmApiKey /= ""
- when (lfmUser /= "" && not lfEnabled) $
- Log.warn "LASTFM_USER is set but LASTFM_API_KEY is missing — Last.fm syncing disabled"
- -- Fork initial syncs in parallel; both run concurrently
- lbFiber <- if lbEnabled then Just <$> forkAff (lbSyncOnce conn username isSyncing initialSyncEnabled) else pure Nothing
- lfFiber <- if lfEnabled then Just <$> forkAff (lfSyncOnce conn lfmApiKey lfmUser isSyncing initialSyncEnabled) else pure Nothing
- -- Block until both initial syncs have fully paginated through history
+
+ case config.lastfmUser, config.lastfmApiKey of
+ Just _, Nothing -> Log.warn $ "lastfmUser set for user '" <> slug <> "' but lastfmApiKey is missing — Last.fm sync disabled"
+ _, _ -> pure unit
+
+ -- Run initial syncs in parallel, then join before starting loops.
+ lbFiber <- case config.listenbrainzUser of
+ Just username -> Just <$> forkAff (lbSyncOnce conn username isSyncing config.initialSync)
+ Nothing -> pure Nothing
+ lfFiber <- case config.lastfmUser, config.lastfmApiKey of
+ Just lfmUser, Just apiKey -> Just <$> forkAff (lfSyncOnce conn apiKey lfmUser isSyncing config.initialSync)
+ _, _ -> pure Nothing
for_ lbFiber joinFiber
for_ lfFiber joinFiber
- -- Only now start enrichment and the recurring sync loops
- void $ forkAff $ enrichMetadata conn isSyncing
- when lbEnabled $ void $ forkAff $ lbSyncLoop conn username isSyncing initialSyncEnabled
- when lfEnabled $ void $ forkAff $ lfSyncLoop conn lfmApiKey lfmUser isSyncing initialSyncEnabled
- when backupEnabled $ void $ forkAff $ backupDb conn dbFile backupIntervalMs
-
- liftEffect $ do
- server <- createServer
- server # on_ Server.requestH (handleRequest conn isSyncing coverCacheEnabled)
- let netServer = Server.toNetServer server
- netServer # on_ listeningH do
- Log.info $ "Server is running on port " <> show port
+ -- Background loops
+ void $ forkAff $ enrichMetadata conn isSyncing config
+ for_ config.listenbrainzUser \username ->
+ void $ forkAff $ lbSyncLoop conn username isSyncing config.initialSync
+ case config.lastfmUser, config.lastfmApiKey of
+ Just lfmUser, Just apiKey -> void $ forkAff $ lfSyncLoop conn apiKey lfmUser isSyncing config.initialSync
+ _, _ -> pure unit
+ when config.backupEnabled $ void $ forkAff $
+ backupDb conn config.databaseFile (s3ConfigFromUser config)
+ (toNumber config.backupIntervalHours * 3600000.0)
- listenTcp netServer { host: "127.0.0.1", port, backlog: 128 }
+ pure { conn, isSyncing, config, slug }
foreign import dotenvConfig :: Effect Unit
-getEnvStr :: Object.Object String -> String -> String -> String
-getEnvStr env key def = fromMaybe def (Object.lookup key env)
-
-getEnvInt :: Object.Object String -> String -> Int -> Int
-getEnvInt env key def = fromMaybe def (Object.lookup key env >>= fromString)
-
-getEnvBool :: Object.Object String -> String -> Boolean -> Boolean
-getEnvBool env key def = case Object.lookup key env of
- Just "true" -> true
- Just "false" -> false
- _ -> def
-
main :: Effect Unit
main = do
dotenvConfig
- env <- getEnv
- let
- port = getEnvInt env "PORT" 8000
- dbFile = getEnvStr env "DATABASE_FILE" "corpus.db"
- username = getEnvStr env "LISTENBRAINZ_USER" ""
- backupEnabled = getEnvBool env "BACKUP_ENABLED" false
- backupIntervalHours = getEnvInt env "BACKUP_INTERVAL_HOURS" 1
- backupIntervalMs = toNumber backupIntervalHours * 3600000.0
- coverCacheEnabled = getEnvBool env "COVER_CACHE_ENABLED" true
- initialSyncEnabled = getEnvBool env "INITIAL_SYNC" false
-
- startServer port dbFile username backupEnabled backupIntervalMs coverCacheEnabled initialSyncEnabled
+ launchAff_ do
+ configFile <- liftEffect $ map (fromMaybe "users.json") $ lookupEnv "CORPUS_CONFIG_FILE"
+ result <- try $ loadConfig configFile
+ case result of
+ Left err -> do
+ 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 users.dhall"
+ contexts <- traverse startUser appConfig.users
+ liftEffect $ do
+ server <- createServer
+ server # on_ Server.requestH (handleRequest contexts)
+ let netServer = Server.toNetServer server
+
+ netServer # on_ listeningH do
+ Log.info $ "Server is running on port " <> show appConfig.port
+
+ listenTcp netServer { host: "127.0.0.1", port: appConfig.port, backlog: 128 }
diff --git a/src/S3.js b/src/S3.js
@@ -4,22 +4,25 @@ import {
HeadObjectCommand,
} from "@aws-sdk/client-s3";
-const getClient = () =>
+const makeClient = (cfg) =>
new S3Client({
- region: process.env.S3_REGION || "us-east-1",
- endpoint: process.env.AWS_ENDPOINT_URL,
- forcePathStyle: process.env.AWS_S3_ADDRESSING_STYLE === "path",
- credentials: {
- accessKeyId: process.env.AWS_ACCESS_KEY_ID,
- secretAccessKey: process.env.AWS_SECRET_ACCESS_KEY,
- },
+ region: cfg.region || "us-east-1",
+ endpoint: cfg.endpointUrl ?? undefined,
+ forcePathStyle: cfg.addressingStyle === "path",
+ credentials:
+ cfg.accessKeyId && cfg.secretAccessKey
+ ? {
+ accessKeyId: cfg.accessKeyId,
+ secretAccessKey: cfg.secretAccessKey,
+ }
+ : undefined,
});
export const uploadToS3Impl =
- (key) => (body) => (contentType) => (cb) => () => {
- const client = getClient();
+ (cfg) => (key) => (body) => (contentType) => (cb) => () => {
+ const client = makeClient(cfg);
const command = new PutObjectCommand({
- Bucket: process.env.S3_BUCKET,
+ Bucket: cfg.bucket,
Key: key,
Body: body,
ContentType: contentType,
@@ -27,12 +30,10 @@ export const uploadToS3Impl =
client
.send(command)
- .then(() => {
- cb(null)();
- })
+ .then(() => cb(null)())
.catch((err) => {
const msg =
- `S3: Upload failed for ${key} ${err.message || err}`.replace(
+ `S3: Upload failed for ${key}: ${err.message || err}`.replace(
/\n/g,
" ",
);
@@ -41,10 +42,10 @@ export const uploadToS3Impl =
});
};
-export const existsInS3Impl = (key) => (cb) => () => {
- const client = getClient();
+export const existsInS3Impl = (cfg) => (key) => (cb) => () => {
+ const client = makeClient(cfg);
const command = new HeadObjectCommand({
- Bucket: process.env.S3_BUCKET,
+ Bucket: cfg.bucket,
Key: key,
});
@@ -56,7 +57,7 @@ export const existsInS3Impl = (key) => (cb) => () => {
cb(false)();
} else {
const msg =
- `S3: exists check failed for ${key} ${err.message || err}`.replace(
+ `S3: exists check failed for ${key}: ${err.message || err}`.replace(
/\n/g,
" ",
);
@@ -66,10 +67,10 @@ export const existsInS3Impl = (key) => (cb) => () => {
});
};
-export const getS3UrlImpl = (key) => {
- const endpoint = process.env.AWS_ENDPOINT_URL || "";
- const bucket = process.env.S3_BUCKET || "";
- if (process.env.AWS_S3_ADDRESSING_STYLE === "path") {
+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}`;
diff --git a/src/S3.purs b/src/S3.purs
@@ -2,30 +2,54 @@ module S3 where
import Prelude
+import Config (S3Config)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
+import Data.Nullable (Nullable, toMaybe, toNullable)
import Effect (Effect)
import Effect.Aff (Aff, makeAff, nonCanceler)
import Effect.Exception (Error)
import Node.Buffer (Buffer)
-import Data.Nullable (Nullable, toMaybe)
-foreign import uploadToS3Impl :: String -> Buffer -> String -> (Nullable Error -> Effect Unit) -> Effect Unit
-foreign import existsInS3Impl :: String -> (Boolean -> Effect Unit) -> Effect Unit
-foreign import getS3UrlImpl :: String -> String
+type S3ConfigJs =
+ { bucket :: Nullable String
+ , region :: String
+ , accessKeyId :: Nullable String
+ , secretAccessKey :: Nullable String
+ , endpointUrl :: Nullable String
+ , addressingStyle :: Nullable String
+ }
-uploadToS3 :: String -> Buffer -> String -> Aff Unit
-uploadToS3 key body contentType = makeAff \cb -> do
- uploadToS3Impl key body contentType \err ->
+toJs :: S3Config -> S3ConfigJs
+toJs cfg =
+ { bucket: toNullable cfg.bucket
+ , region: cfg.region
+ , accessKeyId: toNullable cfg.accessKeyId
+ , secretAccessKey: toNullable cfg.secretAccessKey
+ , endpointUrl: toNullable cfg.endpointUrl
+ , addressingStyle: toNullable cfg.addressingStyle
+ }
+
+foreign import uploadToS3Impl
+ :: S3ConfigJs -> String -> Buffer -> String -> (Nullable Error -> Effect Unit) -> Effect Unit
+
+foreign import existsInS3Impl
+ :: S3ConfigJs -> String -> (Boolean -> Effect Unit) -> Effect Unit
+
+foreign import getS3UrlImpl :: S3ConfigJs -> String -> String
+
+uploadToS3 :: S3Config -> String -> Buffer -> String -> Aff Unit
+uploadToS3 cfg key body contentType = makeAff \cb -> do
+ uploadToS3Impl (toJs cfg) key body contentType \err ->
case toMaybe err of
Just e -> cb (Left e)
Nothing -> cb (Right unit)
pure nonCanceler
-existsInS3 :: String -> Aff Boolean
-existsInS3 key = makeAff \cb -> do
- existsInS3Impl key \exists -> cb (Right exists)
+existsInS3 :: S3Config -> String -> Aff Boolean
+existsInS3 cfg key = makeAff \cb -> do
+ existsInS3Impl (toJs cfg) key \exists -> cb (Right exists)
pure nonCanceler
-getS3Url :: String -> String
-getS3Url = getS3UrlImpl
+getS3Url :: S3Config -> String -> String
+getS3Url cfg = getS3UrlImpl (toJs cfg)
diff --git a/test/Main.purs b/test/Main.purs
@@ -7,8 +7,6 @@ import Data.Array (length)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Effect (Effect)
-import Effect.Class (liftEffect)
-import Node.Process as Process
import Test.Spec (describe, it)
import Test.Spec.Assertions (shouldEqual, fail)
import Test.Spec.Reporter.Console (consoleReporter)
@@ -20,11 +18,7 @@ import Main (sanitizeKey, listenBrainzUrl, lastfmTrackToListen)
import S3 (getS3Url)
main :: Effect Unit
-main = do
- Process.setEnv "AWS_ENDPOINT_URL" "https://s3.example.com"
- Process.setEnv "S3_BUCKET" "my-bucket"
-
- runSpecAndExitProcess [consoleReporter] do
+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"
@@ -275,11 +269,25 @@ main = do
describe "Corpus S3" do
it "should generate virtual-host style S3 URLs" do
- liftEffect $ Process.setEnv "AWS_S3_ADDRESSING_STYLE" "virtual"
- let url = getS3Url "covers/test.jpg"
- url `shouldEqual` "https://my-bucket.s3.example.com/covers/test.jpg"
+ 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"
it "should generate path-style S3 URLs" do
- liftEffect $ Process.setEnv "AWS_S3_ADDRESSING_STYLE" "path"
- let url = getS3Url "covers/test.jpg"
- url `shouldEqual` "https://s3.example.com/my-bucket/covers/test.jpg"
+ 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"
diff --git a/users.dhall b/users.dhall
@@ -0,0 +1,46 @@
+let UserConfig =
+ { listenbrainzUser : Optional Text
+ , lastfmUser : Optional Text
+ , databaseFile : Text
+ , coverCacheEnabled : Bool
+ , backupEnabled : Bool
+ , backupIntervalHours : Natural
+ , initialSync : Bool
+ }
+
+let defaults
+ : UserConfig
+ = { listenbrainzUser = None Text
+ , lastfmUser = None Text
+ , databaseFile = "corpus.db"
+ , coverCacheEnabled = True
+ , backupEnabled = False
+ , backupIntervalHours = 1
+ , initialSync = False
+ }
+
+in { users =
+ [ { slug = ""
+ , config =
+ defaults
+ with listenbrainzUser = Some "mtmn"
+ with databaseFile = "corpus-mtmn.db"
+ with backupEnabled = True
+ }
+ , { slug = "lastfm"
+ , config =
+ defaults
+ with lastfmUser = Some "mtmnn"
+ with databaseFile = "corpus-lastfm-mtmnn.db"
+ with backupEnabled = True
+ }
+ , { slug = "other_listenbrainz"
+ , config =
+ defaults
+ with lastfmUser = Some "otheruser"
+ with databaseFile = "corpus-lb-otheruser.db"
+ with backupEnabled = False
+ with initialSync = True
+ }
+ ]
+ }
diff --git a/users.json b/users.json
@@ -0,0 +1,38 @@
+{
+ "port": 8000,
+ "users": [
+ {
+ "config": {
+ "backupEnabled": true,
+ "backupIntervalHours": 1,
+ "coverCacheEnabled": true,
+ "databaseFile": "corpus-mtmn.db",
+ "initialSync": false,
+ "listenbrainzUser": "mtmn"
+ },
+ "slug": ""
+ },
+ {
+ "config": {
+ "backupEnabled": true,
+ "backupIntervalHours": 1,
+ "coverCacheEnabled": true,
+ "databaseFile": "corpus-lastfm-mtmnn.db",
+ "initialSync": false,
+ "lastfmUser": "mtmnn"
+ },
+ "slug": "lastfm"
+ },
+ {
+ "config": {
+ "backupEnabled": false,
+ "backupIntervalHours": 1,
+ "coverCacheEnabled": true,
+ "databaseFile": "corpus-lb-otheruser.db",
+ "initialSync": true,
+ "lastfmUser": "otheruser"
+ },
+ "slug": "other_listenbrainz"
+ }
+ ]
+}
