commit 4f9a89ce5d24a41211ff9d220f73fb72b12435fa
parent 3ab2cc87e80dbabb273e984b071a9f31e84a9314
Author: Miro Toman <44134862+mtmn@users.noreply.github.com>
Date: Wed, 22 Apr 2026 22:00:47 +0200
Merge pull request #19 from mtmn/feat/decouple-blocks-avif-conversion
feat: decouple large files, convert to avif, housekeeping
Diffstat:
26 files changed, 3045 insertions(+), 2218 deletions(-)
diff --git a/.github/workflows/release-please.yml b/.github/workflows/release-please.yml
@@ -10,9 +10,6 @@ permissions:
jobs:
release-please:
runs-on: ubuntu-latest
- outputs:
- prs_created: ${{ steps.release.outputs.prs_created }}
- pr_branch: ${{ steps.release.outputs.prs_created == 'true' && fromJSON(steps.release.outputs.pr).headBranchName || '' }}
steps:
- uses: googleapis/release-please-action@5c625bfb5d1ff62eadeeb3772007f7f66fdcf071 # v4.4.1
id: release
@@ -20,23 +17,3 @@ jobs:
token: ${{ secrets.GITHUB_TOKEN }}
release-type: node
- update-nix-hash:
- runs-on: ubuntu-latest
- needs: release-please
- if: ${{ needs.release-please.outputs.prs_created == 'true' }}
- steps:
- - uses: DeterminateSystems/nix-installer-action@da36cb69b1c3247ad7a1f931ebfd954a1105ef14 # v14
- - name: Update npmDepsHash
- env:
- GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
- BRANCH: ${{ needs.release-please.outputs.pr_branch }}
- run: |
- git clone --depth=1 --branch="$BRANCH" \
- "https://x-access-token:${GITHUB_TOKEN}@github.com/${{ github.repository }}.git" .
- hash=$(nix run nixpkgs#prefetch-npm-deps -- package-lock.json)
- sed -i "s|npmDepsHash = \"sha256-[^\"]*\"|npmDepsHash = \"$hash\"|" flake.nix
- git config user.name "github-actions[bot]"
- git config user.email "github-actions[bot]@users.noreply.github.com"
- git add flake.nix
- git diff --staged --quiet || git commit -m "chore: update npmDepsHash"
- git push
diff --git a/.github/workflows/update-nix-hash.yml b/.github/workflows/update-nix-hash.yml
@@ -0,0 +1,29 @@
+on:
+ push:
+
+permissions:
+ contents: write
+
+jobs:
+ update-nix-hash:
+ runs-on: ubuntu-latest
+ steps:
+ - uses: actions/checkout@34e114876b0b11c390a56381ad16ebd13914f8d5 # v4.3.1
+ with:
+ ref: ${{ github.ref }}
+ token: ${{ secrets.GITHUB_TOKEN }}
+
+ - uses: DeterminateSystems/nix-installer-action@da36cb69b1c3247ad7a1f931ebfd954a1105ef14 # v14
+
+ - name: Recompute npmDepsHash
+ run: |
+ hash=$(nix run nixpkgs#prefetch-npm-deps -- package-lock.json)
+ sed -i "s|npmDepsHash = \"sha256-[^\"]*\"|npmDepsHash = \"$hash\"|" flake.nix
+
+ - name: Commit if changed
+ run: |
+ git config user.name "github-actions[bot]"
+ git config user.email "github-actions[bot]@users.noreply.github.com"
+ git add flake.nix
+ git diff --staged --quiet || git commit -m "chore: update npmDepsHash"
+ git push
diff --git a/README.md b/README.md
@@ -75,7 +75,6 @@ npx spago run
| `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 |
-| `initialSync` | `false` | Perform a full historical sync on first run |
| `coverCacheEnabled` | `true` | Enable cover art caching to S3 |
| `backupEnabled` | `false` | Enable database backups to S3 |
| `backupIntervalHours` | `24` | Backup frequency in hours |
diff --git a/docs/architecture.md b/docs/architecture.md
@@ -94,7 +94,6 @@ This prevents data corruption and ensures that any in-progress operations are co
| `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
diff --git a/flake.nix b/flake.nix
@@ -79,7 +79,7 @@
outputHashAlgo = "sha256";
outputHashMode = "recursive";
- outputHash = "sha256-hlMN1T0s8otmQcj/Hinf/FpLWSjAIesE3n3krGBS/WU=";
+ outputHash = "sha256-hUJb0OehrpmhnyQHJf1S9K96q+LoOLinDd8HlgHV+/E=";
buildPhase = ''
export HOME=$TMPDIR
@@ -131,7 +131,7 @@
inherit ((builtins.fromJSON (builtins.readFile ./package.json))) version;
inherit src;
- npmDepsHash = "sha256-Qy2X2mWaQcF895PE3dXqoQj84fdywC7uiIxITuN/YpM=";
+ npmDepsHash = "sha256-A89/7mzFxURQQkgOR7li8vBZnCH2jqtBLxYuFOmsPbw=";
npmRebuildFlags = ["--ignore-scripts"];
nativeBuildInputs = with pkgs; [
diff --git a/package-lock.json b/package-lock.json
@@ -11,7 +11,8 @@
"@aws-sdk/client-s3": "^3.1029.0",
"dotenv": "^17.4.1",
"duckdb": "^1.4.4",
- "prom-client": "^15.1.3"
+ "prom-client": "^15.1.3",
+ "sharp": "^0.34.5"
},
"devDependencies": {
"elm": "^0.19.1",
@@ -876,6 +877,16 @@
"node": ">=18.0.0"
}
},
+ "node_modules/@emnapi/runtime": {
+ "version": "1.10.0",
+ "resolved": "https://registry.npmjs.org/@emnapi/runtime/-/runtime-1.10.0.tgz",
+ "integrity": "sha512-ewvYlk86xUoGI0zQRNq/mC+16R1QeDlKQy21Ki3oSYXNgLb45GV1P6A0M+/s6nyCuNDqe5VpaY84BzXGwVbwFA==",
+ "license": "MIT",
+ "optional": true,
+ "dependencies": {
+ "tslib": "^2.4.0"
+ }
+ },
"node_modules/@esbuild/aix-ppc64": {
"version": "0.28.0",
"resolved": "https://registry.npmjs.org/@esbuild/aix-ppc64/-/aix-ppc64-0.28.0.tgz",
@@ -1324,6 +1335,471 @@
"integrity": "sha512-k2Ty1JcVojjJFwrg/ThKi2ujJ7XNLYaFGNB/bWT9wGR+oSMJHMa5w+CUq6p/pVrKeNNgA7pCqEcjSnHVoqJQFw==",
"license": "MIT"
},
+ "node_modules/@img/colour": {
+ "version": "1.1.0",
+ "resolved": "https://registry.npmjs.org/@img/colour/-/colour-1.1.0.tgz",
+ "integrity": "sha512-Td76q7j57o/tLVdgS746cYARfSyxk8iEfRxewL9h4OMzYhbW4TAcppl0mT4eyqXddh6L/jwoM75mo7ixa/pCeQ==",
+ "license": "MIT",
+ "engines": {
+ "node": ">=18"
+ }
+ },
+ "node_modules/@img/sharp-darwin-arm64": {
+ "version": "0.34.5",
+ "resolved": "https://registry.npmjs.org/@img/sharp-darwin-arm64/-/sharp-darwin-arm64-0.34.5.tgz",
+ "integrity": "sha512-imtQ3WMJXbMY4fxb/Ndp6HBTNVtWCUI0WdobyheGf5+ad6xX8VIDO8u2xE4qc/fr08CKG/7dDseFtn6M6g/r3w==",
+ "cpu": [
+ "arm64"
+ ],
+ "license": "Apache-2.0",
+ "optional": true,
+ "os": [
+ "darwin"
+ ],
+ "engines": {
+ "node": "^18.17.0 || ^20.3.0 || >=21.0.0"
+ },
+ "funding": {
+ "url": "https://opencollective.com/libvips"
+ },
+ "optionalDependencies": {
+ "@img/sharp-libvips-darwin-arm64": "1.2.4"
+ }
+ },
+ "node_modules/@img/sharp-darwin-x64": {
+ "version": "0.34.5",
+ "resolved": "https://registry.npmjs.org/@img/sharp-darwin-x64/-/sharp-darwin-x64-0.34.5.tgz",
+ "integrity": "sha512-YNEFAF/4KQ/PeW0N+r+aVVsoIY0/qxxikF2SWdp+NRkmMB7y9LBZAVqQ4yhGCm/H3H270OSykqmQMKLBhBJDEw==",
+ "cpu": [
+ "x64"
+ ],
+ "license": "Apache-2.0",
+ "optional": true,
+ "os": [
+ "darwin"
+ ],
+ "engines": {
+ "node": "^18.17.0 || ^20.3.0 || >=21.0.0"
+ },
+ "funding": {
+ "url": "https://opencollective.com/libvips"
+ },
+ "optionalDependencies": {
+ "@img/sharp-libvips-darwin-x64": "1.2.4"
+ }
+ },
+ "node_modules/@img/sharp-libvips-darwin-arm64": {
+ "version": "1.2.4",
+ "resolved": "https://registry.npmjs.org/@img/sharp-libvips-darwin-arm64/-/sharp-libvips-darwin-arm64-1.2.4.tgz",
+ "integrity": "sha512-zqjjo7RatFfFoP0MkQ51jfuFZBnVE2pRiaydKJ1G/rHZvnsrHAOcQALIi9sA5co5xenQdTugCvtb1cuf78Vf4g==",
+ "cpu": [
+ "arm64"
+ ],
+ "license": "LGPL-3.0-or-later",
+ "optional": true,
+ "os": [
+ "darwin"
+ ],
+ "funding": {
+ "url": "https://opencollective.com/libvips"
+ }
+ },
+ "node_modules/@img/sharp-libvips-darwin-x64": {
+ "version": "1.2.4",
+ "resolved": "https://registry.npmjs.org/@img/sharp-libvips-darwin-x64/-/sharp-libvips-darwin-x64-1.2.4.tgz",
+ "integrity": "sha512-1IOd5xfVhlGwX+zXv2N93k0yMONvUlANylbJw1eTah8K/Jtpi15KC+WSiaX/nBmbm2HxRM1gZ0nSdjSsrZbGKg==",
+ "cpu": [
+ "x64"
+ ],
+ "license": "LGPL-3.0-or-later",
+ "optional": true,
+ "os": [
+ "darwin"
+ ],
+ "funding": {
+ "url": "https://opencollective.com/libvips"
+ }
+ },
+ "node_modules/@img/sharp-libvips-linux-arm": {
+ "version": "1.2.4",
+ "resolved": "https://registry.npmjs.org/@img/sharp-libvips-linux-arm/-/sharp-libvips-linux-arm-1.2.4.tgz",
+ "integrity": "sha512-bFI7xcKFELdiNCVov8e44Ia4u2byA+l3XtsAj+Q8tfCwO6BQ8iDojYdvoPMqsKDkuoOo+X6HZA0s0q11ANMQ8A==",
+ "cpu": [
+ "arm"
+ ],
+ "license": "LGPL-3.0-or-later",
+ "optional": true,
+ "os": [
+ "linux"
+ ],
+ "funding": {
+ "url": "https://opencollective.com/libvips"
+ }
+ },
+ "node_modules/@img/sharp-libvips-linux-arm64": {
+ "version": "1.2.4",
+ "resolved": "https://registry.npmjs.org/@img/sharp-libvips-linux-arm64/-/sharp-libvips-linux-arm64-1.2.4.tgz",
+ "integrity": "sha512-excjX8DfsIcJ10x1Kzr4RcWe1edC9PquDRRPx3YVCvQv+U5p7Yin2s32ftzikXojb1PIFc/9Mt28/y+iRklkrw==",
+ "cpu": [
+ "arm64"
+ ],
+ "license": "LGPL-3.0-or-later",
+ "optional": true,
+ "os": [
+ "linux"
+ ],
+ "funding": {
+ "url": "https://opencollective.com/libvips"
+ }
+ },
+ "node_modules/@img/sharp-libvips-linux-ppc64": {
+ "version": "1.2.4",
+ "resolved": "https://registry.npmjs.org/@img/sharp-libvips-linux-ppc64/-/sharp-libvips-linux-ppc64-1.2.4.tgz",
+ "integrity": "sha512-FMuvGijLDYG6lW+b/UvyilUWu5Ayu+3r2d1S8notiGCIyYU/76eig1UfMmkZ7vwgOrzKzlQbFSuQfgm7GYUPpA==",
+ "cpu": [
+ "ppc64"
+ ],
+ "license": "LGPL-3.0-or-later",
+ "optional": true,
+ "os": [
+ "linux"
+ ],
+ "funding": {
+ "url": "https://opencollective.com/libvips"
+ }
+ },
+ "node_modules/@img/sharp-libvips-linux-riscv64": {
+ "version": "1.2.4",
+ "resolved": "https://registry.npmjs.org/@img/sharp-libvips-linux-riscv64/-/sharp-libvips-linux-riscv64-1.2.4.tgz",
+ "integrity": "sha512-oVDbcR4zUC0ce82teubSm+x6ETixtKZBh/qbREIOcI3cULzDyb18Sr/Wcyx7NRQeQzOiHTNbZFF1UwPS2scyGA==",
+ "cpu": [
+ "riscv64"
+ ],
+ "license": "LGPL-3.0-or-later",
+ "optional": true,
+ "os": [
+ "linux"
+ ],
+ "funding": {
+ "url": "https://opencollective.com/libvips"
+ }
+ },
+ "node_modules/@img/sharp-libvips-linux-s390x": {
+ "version": "1.2.4",
+ "resolved": "https://registry.npmjs.org/@img/sharp-libvips-linux-s390x/-/sharp-libvips-linux-s390x-1.2.4.tgz",
+ "integrity": "sha512-qmp9VrzgPgMoGZyPvrQHqk02uyjA0/QrTO26Tqk6l4ZV0MPWIW6LTkqOIov+J1yEu7MbFQaDpwdwJKhbJvuRxQ==",
+ "cpu": [
+ "s390x"
+ ],
+ "license": "LGPL-3.0-or-later",
+ "optional": true,
+ "os": [
+ "linux"
+ ],
+ "funding": {
+ "url": "https://opencollective.com/libvips"
+ }
+ },
+ "node_modules/@img/sharp-libvips-linux-x64": {
+ "version": "1.2.4",
+ "resolved": "https://registry.npmjs.org/@img/sharp-libvips-linux-x64/-/sharp-libvips-linux-x64-1.2.4.tgz",
+ "integrity": "sha512-tJxiiLsmHc9Ax1bz3oaOYBURTXGIRDODBqhveVHonrHJ9/+k89qbLl0bcJns+e4t4rvaNBxaEZsFtSfAdquPrw==",
+ "cpu": [
+ "x64"
+ ],
+ "license": "LGPL-3.0-or-later",
+ "optional": true,
+ "os": [
+ "linux"
+ ],
+ "funding": {
+ "url": "https://opencollective.com/libvips"
+ }
+ },
+ "node_modules/@img/sharp-libvips-linuxmusl-arm64": {
+ "version": "1.2.4",
+ "resolved": "https://registry.npmjs.org/@img/sharp-libvips-linuxmusl-arm64/-/sharp-libvips-linuxmusl-arm64-1.2.4.tgz",
+ "integrity": "sha512-FVQHuwx1IIuNow9QAbYUzJ+En8KcVm9Lk5+uGUQJHaZmMECZmOlix9HnH7n1TRkXMS0pGxIJokIVB9SuqZGGXw==",
+ "cpu": [
+ "arm64"
+ ],
+ "license": "LGPL-3.0-or-later",
+ "optional": true,
+ "os": [
+ "linux"
+ ],
+ "funding": {
+ "url": "https://opencollective.com/libvips"
+ }
+ },
+ "node_modules/@img/sharp-libvips-linuxmusl-x64": {
+ "version": "1.2.4",
+ "resolved": "https://registry.npmjs.org/@img/sharp-libvips-linuxmusl-x64/-/sharp-libvips-linuxmusl-x64-1.2.4.tgz",
+ "integrity": "sha512-+LpyBk7L44ZIXwz/VYfglaX/okxezESc6UxDSoyo2Ks6Jxc4Y7sGjpgU9s4PMgqgjj1gZCylTieNamqA1MF7Dg==",
+ "cpu": [
+ "x64"
+ ],
+ "license": "LGPL-3.0-or-later",
+ "optional": true,
+ "os": [
+ "linux"
+ ],
+ "funding": {
+ "url": "https://opencollective.com/libvips"
+ }
+ },
+ "node_modules/@img/sharp-linux-arm": {
+ "version": "0.34.5",
+ "resolved": "https://registry.npmjs.org/@img/sharp-linux-arm/-/sharp-linux-arm-0.34.5.tgz",
+ "integrity": "sha512-9dLqsvwtg1uuXBGZKsxem9595+ujv0sJ6Vi8wcTANSFpwV/GONat5eCkzQo/1O6zRIkh0m/8+5BjrRr7jDUSZw==",
+ "cpu": [
+ "arm"
+ ],
+ "license": "Apache-2.0",
+ "optional": true,
+ "os": [
+ "linux"
+ ],
+ "engines": {
+ "node": "^18.17.0 || ^20.3.0 || >=21.0.0"
+ },
+ "funding": {
+ "url": "https://opencollective.com/libvips"
+ },
+ "optionalDependencies": {
+ "@img/sharp-libvips-linux-arm": "1.2.4"
+ }
+ },
+ "node_modules/@img/sharp-linux-arm64": {
+ "version": "0.34.5",
+ "resolved": "https://registry.npmjs.org/@img/sharp-linux-arm64/-/sharp-linux-arm64-0.34.5.tgz",
+ "integrity": "sha512-bKQzaJRY/bkPOXyKx5EVup7qkaojECG6NLYswgktOZjaXecSAeCWiZwwiFf3/Y+O1HrauiE3FVsGxFg8c24rZg==",
+ "cpu": [
+ "arm64"
+ ],
+ "license": "Apache-2.0",
+ "optional": true,
+ "os": [
+ "linux"
+ ],
+ "engines": {
+ "node": "^18.17.0 || ^20.3.0 || >=21.0.0"
+ },
+ "funding": {
+ "url": "https://opencollective.com/libvips"
+ },
+ "optionalDependencies": {
+ "@img/sharp-libvips-linux-arm64": "1.2.4"
+ }
+ },
+ "node_modules/@img/sharp-linux-ppc64": {
+ "version": "0.34.5",
+ "resolved": "https://registry.npmjs.org/@img/sharp-linux-ppc64/-/sharp-linux-ppc64-0.34.5.tgz",
+ "integrity": "sha512-7zznwNaqW6YtsfrGGDA6BRkISKAAE1Jo0QdpNYXNMHu2+0dTrPflTLNkpc8l7MUP5M16ZJcUvysVWWrMefZquA==",
+ "cpu": [
+ "ppc64"
+ ],
+ "license": "Apache-2.0",
+ "optional": true,
+ "os": [
+ "linux"
+ ],
+ "engines": {
+ "node": "^18.17.0 || ^20.3.0 || >=21.0.0"
+ },
+ "funding": {
+ "url": "https://opencollective.com/libvips"
+ },
+ "optionalDependencies": {
+ "@img/sharp-libvips-linux-ppc64": "1.2.4"
+ }
+ },
+ "node_modules/@img/sharp-linux-riscv64": {
+ "version": "0.34.5",
+ "resolved": "https://registry.npmjs.org/@img/sharp-linux-riscv64/-/sharp-linux-riscv64-0.34.5.tgz",
+ "integrity": "sha512-51gJuLPTKa7piYPaVs8GmByo7/U7/7TZOq+cnXJIHZKavIRHAP77e3N2HEl3dgiqdD/w0yUfiJnII77PuDDFdw==",
+ "cpu": [
+ "riscv64"
+ ],
+ "license": "Apache-2.0",
+ "optional": true,
+ "os": [
+ "linux"
+ ],
+ "engines": {
+ "node": "^18.17.0 || ^20.3.0 || >=21.0.0"
+ },
+ "funding": {
+ "url": "https://opencollective.com/libvips"
+ },
+ "optionalDependencies": {
+ "@img/sharp-libvips-linux-riscv64": "1.2.4"
+ }
+ },
+ "node_modules/@img/sharp-linux-s390x": {
+ "version": "0.34.5",
+ "resolved": "https://registry.npmjs.org/@img/sharp-linux-s390x/-/sharp-linux-s390x-0.34.5.tgz",
+ "integrity": "sha512-nQtCk0PdKfho3eC5MrbQoigJ2gd1CgddUMkabUj+rBevs8tZ2cULOx46E7oyX+04WGfABgIwmMC0VqieTiR4jg==",
+ "cpu": [
+ "s390x"
+ ],
+ "license": "Apache-2.0",
+ "optional": true,
+ "os": [
+ "linux"
+ ],
+ "engines": {
+ "node": "^18.17.0 || ^20.3.0 || >=21.0.0"
+ },
+ "funding": {
+ "url": "https://opencollective.com/libvips"
+ },
+ "optionalDependencies": {
+ "@img/sharp-libvips-linux-s390x": "1.2.4"
+ }
+ },
+ "node_modules/@img/sharp-linux-x64": {
+ "version": "0.34.5",
+ "resolved": "https://registry.npmjs.org/@img/sharp-linux-x64/-/sharp-linux-x64-0.34.5.tgz",
+ "integrity": "sha512-MEzd8HPKxVxVenwAa+JRPwEC7QFjoPWuS5NZnBt6B3pu7EG2Ge0id1oLHZpPJdn3OQK+BQDiw9zStiHBTJQQQQ==",
+ "cpu": [
+ "x64"
+ ],
+ "license": "Apache-2.0",
+ "optional": true,
+ "os": [
+ "linux"
+ ],
+ "engines": {
+ "node": "^18.17.0 || ^20.3.0 || >=21.0.0"
+ },
+ "funding": {
+ "url": "https://opencollective.com/libvips"
+ },
+ "optionalDependencies": {
+ "@img/sharp-libvips-linux-x64": "1.2.4"
+ }
+ },
+ "node_modules/@img/sharp-linuxmusl-arm64": {
+ "version": "0.34.5",
+ "resolved": "https://registry.npmjs.org/@img/sharp-linuxmusl-arm64/-/sharp-linuxmusl-arm64-0.34.5.tgz",
+ "integrity": "sha512-fprJR6GtRsMt6Kyfq44IsChVZeGN97gTD331weR1ex1c1rypDEABN6Tm2xa1wE6lYb5DdEnk03NZPqA7Id21yg==",
+ "cpu": [
+ "arm64"
+ ],
+ "license": "Apache-2.0",
+ "optional": true,
+ "os": [
+ "linux"
+ ],
+ "engines": {
+ "node": "^18.17.0 || ^20.3.0 || >=21.0.0"
+ },
+ "funding": {
+ "url": "https://opencollective.com/libvips"
+ },
+ "optionalDependencies": {
+ "@img/sharp-libvips-linuxmusl-arm64": "1.2.4"
+ }
+ },
+ "node_modules/@img/sharp-linuxmusl-x64": {
+ "version": "0.34.5",
+ "resolved": "https://registry.npmjs.org/@img/sharp-linuxmusl-x64/-/sharp-linuxmusl-x64-0.34.5.tgz",
+ "integrity": "sha512-Jg8wNT1MUzIvhBFxViqrEhWDGzqymo3sV7z7ZsaWbZNDLXRJZoRGrjulp60YYtV4wfY8VIKcWidjojlLcWrd8Q==",
+ "cpu": [
+ "x64"
+ ],
+ "license": "Apache-2.0",
+ "optional": true,
+ "os": [
+ "linux"
+ ],
+ "engines": {
+ "node": "^18.17.0 || ^20.3.0 || >=21.0.0"
+ },
+ "funding": {
+ "url": "https://opencollective.com/libvips"
+ },
+ "optionalDependencies": {
+ "@img/sharp-libvips-linuxmusl-x64": "1.2.4"
+ }
+ },
+ "node_modules/@img/sharp-wasm32": {
+ "version": "0.34.5",
+ "resolved": "https://registry.npmjs.org/@img/sharp-wasm32/-/sharp-wasm32-0.34.5.tgz",
+ "integrity": "sha512-OdWTEiVkY2PHwqkbBI8frFxQQFekHaSSkUIJkwzclWZe64O1X4UlUjqqqLaPbUpMOQk6FBu/HtlGXNblIs0huw==",
+ "cpu": [
+ "wasm32"
+ ],
+ "license": "Apache-2.0 AND LGPL-3.0-or-later AND MIT",
+ "optional": true,
+ "dependencies": {
+ "@emnapi/runtime": "^1.7.0"
+ },
+ "engines": {
+ "node": "^18.17.0 || ^20.3.0 || >=21.0.0"
+ },
+ "funding": {
+ "url": "https://opencollective.com/libvips"
+ }
+ },
+ "node_modules/@img/sharp-win32-arm64": {
+ "version": "0.34.5",
+ "resolved": "https://registry.npmjs.org/@img/sharp-win32-arm64/-/sharp-win32-arm64-0.34.5.tgz",
+ "integrity": "sha512-WQ3AgWCWYSb2yt+IG8mnC6Jdk9Whs7O0gxphblsLvdhSpSTtmu69ZG1Gkb6NuvxsNACwiPV6cNSZNzt0KPsw7g==",
+ "cpu": [
+ "arm64"
+ ],
+ "license": "Apache-2.0 AND LGPL-3.0-or-later",
+ "optional": true,
+ "os": [
+ "win32"
+ ],
+ "engines": {
+ "node": "^18.17.0 || ^20.3.0 || >=21.0.0"
+ },
+ "funding": {
+ "url": "https://opencollective.com/libvips"
+ }
+ },
+ "node_modules/@img/sharp-win32-ia32": {
+ "version": "0.34.5",
+ "resolved": "https://registry.npmjs.org/@img/sharp-win32-ia32/-/sharp-win32-ia32-0.34.5.tgz",
+ "integrity": "sha512-FV9m/7NmeCmSHDD5j4+4pNI8Cp3aW+JvLoXcTUo0IqyjSfAZJ8dIUmijx1qaJsIiU+Hosw6xM5KijAWRJCSgNg==",
+ "cpu": [
+ "ia32"
+ ],
+ "license": "Apache-2.0 AND LGPL-3.0-or-later",
+ "optional": true,
+ "os": [
+ "win32"
+ ],
+ "engines": {
+ "node": "^18.17.0 || ^20.3.0 || >=21.0.0"
+ },
+ "funding": {
+ "url": "https://opencollective.com/libvips"
+ }
+ },
+ "node_modules/@img/sharp-win32-x64": {
+ "version": "0.34.5",
+ "resolved": "https://registry.npmjs.org/@img/sharp-win32-x64/-/sharp-win32-x64-0.34.5.tgz",
+ "integrity": "sha512-+29YMsqY2/9eFEiW93eqWnuLcWcufowXewwSNIT6UwZdUUCrM3oFjMWH/Z6/TMmb4hlFenmfAVbpWeup2jryCw==",
+ "cpu": [
+ "x64"
+ ],
+ "license": "Apache-2.0 AND LGPL-3.0-or-later",
+ "optional": true,
+ "os": [
+ "win32"
+ ],
+ "engines": {
+ "node": "^18.17.0 || ^20.3.0 || >=21.0.0"
+ },
+ "funding": {
+ "url": "https://opencollective.com/libvips"
+ }
+ },
"node_modules/@isaacs/cliui": {
"version": "9.0.0",
"resolved": "https://registry.npmjs.org/@isaacs/cliui/-/cliui-9.0.0.tgz",
@@ -5294,6 +5770,50 @@
"integrity": "sha512-KiKBS8AnWGEyLzofFfmvKwpdPzqiy16LvQfK3yv/fVH7Bj13/wl3JSR1J+rfgRE9q7xUJK4qvgS8raSOeLUehw==",
"license": "ISC"
},
+ "node_modules/sharp": {
+ "version": "0.34.5",
+ "resolved": "https://registry.npmjs.org/sharp/-/sharp-0.34.5.tgz",
+ "integrity": "sha512-Ou9I5Ft9WNcCbXrU9cMgPBcCK8LiwLqcbywW3t4oDV37n1pzpuNLsYiAV8eODnjbtQlSDwZ2cUEeQz4E54Hltg==",
+ "hasInstallScript": true,
+ "license": "Apache-2.0",
+ "dependencies": {
+ "@img/colour": "^1.0.0",
+ "detect-libc": "^2.1.2",
+ "semver": "^7.7.3"
+ },
+ "engines": {
+ "node": "^18.17.0 || ^20.3.0 || >=21.0.0"
+ },
+ "funding": {
+ "url": "https://opencollective.com/libvips"
+ },
+ "optionalDependencies": {
+ "@img/sharp-darwin-arm64": "0.34.5",
+ "@img/sharp-darwin-x64": "0.34.5",
+ "@img/sharp-libvips-darwin-arm64": "1.2.4",
+ "@img/sharp-libvips-darwin-x64": "1.2.4",
+ "@img/sharp-libvips-linux-arm": "1.2.4",
+ "@img/sharp-libvips-linux-arm64": "1.2.4",
+ "@img/sharp-libvips-linux-ppc64": "1.2.4",
+ "@img/sharp-libvips-linux-riscv64": "1.2.4",
+ "@img/sharp-libvips-linux-s390x": "1.2.4",
+ "@img/sharp-libvips-linux-x64": "1.2.4",
+ "@img/sharp-libvips-linuxmusl-arm64": "1.2.4",
+ "@img/sharp-libvips-linuxmusl-x64": "1.2.4",
+ "@img/sharp-linux-arm": "0.34.5",
+ "@img/sharp-linux-arm64": "0.34.5",
+ "@img/sharp-linux-ppc64": "0.34.5",
+ "@img/sharp-linux-riscv64": "0.34.5",
+ "@img/sharp-linux-s390x": "0.34.5",
+ "@img/sharp-linux-x64": "0.34.5",
+ "@img/sharp-linuxmusl-arm64": "0.34.5",
+ "@img/sharp-linuxmusl-x64": "0.34.5",
+ "@img/sharp-wasm32": "0.34.5",
+ "@img/sharp-win32-arm64": "0.34.5",
+ "@img/sharp-win32-ia32": "0.34.5",
+ "@img/sharp-win32-x64": "0.34.5"
+ }
+ },
"node_modules/shebang-command": {
"version": "2.0.0",
"resolved": "https://registry.npmjs.org/shebang-command/-/shebang-command-2.0.0.tgz",
diff --git a/package.json b/package.json
@@ -5,8 +5,8 @@
"main": "index.js",
"type": "module",
"scripts": {
- "build": "npx spago build && npx esbuild output/Main/index.js --bundle --platform=node --format=esm --footer:js='main();' --outfile=server.js --external:http --external:https --external:dotenv --external:url --external:duckdb --external:@aws-sdk/client-s3 --external:prom-client && elm make src/Client.elm --output=client.js",
- "release": "npx spago build && npx purs-backend-es build && npx esbuild output-es/Main/index.js --bundle --platform=node --format=esm --footer:js='main();' --outfile=server.js --external:http --external:https --external:dotenv --external:url --external:duckdb --external:@aws-sdk/client-s3 --external:prom-client && elm make src/Client.elm --optimize --output=client.js && npx uglifyjs client.js --compress \"pure_funcs=[F2,F3,F4,F5,F6,F7,F8,F9,A2,A3,A4,A5,A6,A7,A8,A9],pure_getters,keep_fargs=false,unsafe_comps,unsafe\" | npx uglifyjs --mangle --output client.js",
+ "build": "npx spago build && npx esbuild output/Main/index.js --bundle --platform=node --format=esm --footer:js='main();' --outfile=server.js --external:http --external:https --external:dotenv --external:url --external:duckdb --external:@aws-sdk/client-s3 --external:prom-client --external:sharp && elm make src/Client.elm --output=client.js",
+ "release": "npx spago build && npx purs-backend-es build && npx esbuild output-es/Main/index.js --bundle --platform=node --format=esm --footer:js='main();' --outfile=server.js --external:http --external:https --external:dotenv --external:url --external:duckdb --external:@aws-sdk/client-s3 --external:prom-client --external:sharp && elm make src/Client.elm --optimize --output=client.js && npx uglifyjs client.js --compress \"pure_funcs=[F2,F3,F4,F5,F6,F7,F8,F9,A2,A3,A4,A5,A6,A7,A8,A9],pure_getters,keep_fargs=false,unsafe_comps,unsafe\" | npx uglifyjs --mangle --output client.js",
"test": "npx spago test",
"tidy": "purs-tidy format-in-place src/**/*.purs"
},
@@ -25,6 +25,7 @@
"@aws-sdk/client-s3": "^3.1029.0",
"dotenv": "^17.4.1",
"duckdb": "^1.4.4",
- "prom-client": "^15.1.3"
+ "prom-client": "^15.1.3",
+ "sharp": "^0.34.5"
}
}
diff --git a/spago.lock b/spago.lock
@@ -6,6 +6,7 @@
"core": {
"dependencies": [
"aff",
+ "aff-promise",
"aff-retry",
"argonaut",
"argonaut-core",
@@ -721,6 +722,21 @@
"unsafe-coerce"
]
},
+ "aff-promise": {
+ "type": "registry",
+ "version": "4.0.0",
+ "integrity": "sha256-Jgp3y+NWuuAmwz2V3LlWoX+AvxqfVglY77N5zTw8xnI=",
+ "dependencies": [
+ "aff",
+ "control",
+ "effect",
+ "either",
+ "exceptions",
+ "foreign",
+ "prelude",
+ "transformers"
+ ]
+ },
"aff-retry": {
"type": "registry",
"version": "2.0.0",
diff --git a/spago.yaml b/spago.yaml
@@ -2,6 +2,7 @@ package:
name: corpus
dependencies:
- aff
+ - aff-promise
- aff-retry
- argonaut
- argonaut-core
diff --git a/src/Api.elm b/src/Api.elm
@@ -0,0 +1,209 @@
+module Api exposing (fetchListens, fetchSectionData, fetchSimilarTracks, fetchStats, httpErrorToString, listensDecoder, sectionEntriesDecoder, similarTracksDecoder, statsDecoder, statsUrl)
+
+import Http
+import Json.Decode as D exposing (Decoder)
+import Types exposing (ActiveFilter, Listen, Msg(..), Period(..), SimilarTrack, Stats, StatsEntry)
+import Url
+
+
+fetchListens : String -> Int -> Int -> Maybe ActiveFilter -> Maybe String -> Cmd Msg
+fetchListens userSlug limit offset mFilter mSearch =
+ let
+ filterParams =
+ case mFilter of
+ Nothing ->
+ ""
+
+ Just { field, value } ->
+ "&filterField=" ++ field ++ "&filterValue=" ++ Url.percentEncode value
+
+ searchParam =
+ case mSearch of
+ Nothing ->
+ ""
+
+ Just q ->
+ "&search=" ++ Url.percentEncode q
+
+ url =
+ "/proxy?user=" ++ userSlug ++ "&limit=" ++ String.fromInt limit ++ "&offset=" ++ String.fromInt offset ++ filterParams ++ searchParam
+ in
+ Http.get
+ { url = url
+ , expect = Http.expectJson GotListens listensDecoder
+ }
+
+
+fetchStats : String -> Period -> Cmd Msg
+fetchStats userSlug period =
+ Http.get
+ { url = statsUrl userSlug period Nothing
+ , expect = Http.expectJson GotStats statsDecoder
+ }
+
+
+fetchSectionData : String -> Period -> String -> Cmd Msg
+fetchSectionData userSlug period section =
+ Http.get
+ { url = statsUrl userSlug period (Just section)
+ , expect = Http.expectJson (GotSectionData section) (sectionEntriesDecoder section)
+ }
+
+
+statsUrl : String -> Period -> Maybe String -> String
+statsUrl userSlug period mSection =
+ let
+ periodPart =
+ case period of
+ AllTime ->
+ ""
+
+ LastDays n ->
+ "&period=" ++ String.fromInt n
+
+ CustomRange from to ->
+ "&from=" ++ from ++ "&to=" ++ to
+
+ sectionPart =
+ case mSection of
+ Nothing ->
+ ""
+
+ Just sec ->
+ "§ion=" ++ sec
+ in
+ "/stats?user=" ++ userSlug ++ periodPart ++ sectionPart
+
+
+fetchSimilarTracks : String -> String -> Cmd Msg
+fetchSimilarTracks artist track =
+ Http.get
+ { url = "/similar?artist=" ++ Url.percentEncode artist ++ "&track=" ++ Url.percentEncode track
+ , expect = Http.expectJson (FetchSimilarTracks artist track) similarTracksDecoder
+ }
+
+
+httpErrorToString : Http.Error -> String
+httpErrorToString err =
+ case err of
+ Http.BadUrl url ->
+ "Bad URL: " ++ url
+
+ Http.Timeout ->
+ "Request timed out"
+
+ Http.NetworkError ->
+ "Network error"
+
+ Http.BadStatus status ->
+ "Server error: " ++ String.fromInt status
+
+ Http.BadBody body ->
+ "JSON decode error: " ++ body
+
+
+
+-- DECODERS
+
+
+listensDecoder : Decoder (List Listen)
+listensDecoder =
+ D.at [ "payload", "listens" ] (D.list listenDecoder)
+
+
+listenDecoder : Decoder Listen
+listenDecoder =
+ D.map2
+ (\meta listenedAt ->
+ { trackName = meta.trackName
+ , artistName = meta.artistName
+ , releaseName = meta.releaseName
+ , listenedAt = listenedAt
+ , genre = meta.genre
+ , label = meta.label
+ , releaseMbid = meta.releaseMbid
+ , caaReleaseMbid = meta.caaReleaseMbid
+ }
+ )
+ (D.field "track_metadata" trackMetaDecoder)
+ (D.maybe (D.field "listened_at" D.int))
+
+
+type alias TrackMeta =
+ { trackName : Maybe String
+ , artistName : Maybe String
+ , releaseName : Maybe String
+ , genre : Maybe String
+ , releaseMbid : Maybe String
+ , caaReleaseMbid : Maybe String
+ , label : Maybe String
+ }
+
+
+trackMetaDecoder : Decoder TrackMeta
+trackMetaDecoder =
+ D.map7 TrackMeta
+ (D.maybe (D.field "track_name" D.string))
+ (D.maybe (D.field "artist_name" D.string))
+ (D.maybe (D.field "release_name" D.string))
+ (D.maybe (D.field "genre" D.string))
+ (D.maybe (D.at [ "mbid_mapping", "release_mbid" ] D.string))
+ (D.maybe (D.at [ "mbid_mapping", "caa_release_mbid" ] D.string))
+ (D.maybe (D.field "label" D.string))
+
+
+statsDecoder : Decoder Stats
+statsDecoder =
+ D.map5 Stats
+ (D.field "genres" (D.list entryDecoder))
+ (D.field "labels" (D.list entryDecoder))
+ (D.field "years" (D.list entryDecoder))
+ (D.field "artists" (D.list entryDecoder))
+ (D.field "tracks" (D.list entryDecoder))
+
+
+entryDecoder : Decoder StatsEntry
+entryDecoder =
+ D.map2 StatsEntry
+ (D.field "name" D.string)
+ (D.field "count" D.int)
+
+
+sectionEntriesDecoder : String -> Decoder (List StatsEntry)
+sectionEntriesDecoder section =
+ D.map
+ (\stats ->
+ case section of
+ "artist" ->
+ stats.artists
+
+ "track" ->
+ stats.tracks
+
+ "genre" ->
+ stats.genres
+
+ "label" ->
+ stats.labels
+
+ "year" ->
+ stats.years
+
+ _ ->
+ []
+ )
+ statsDecoder
+
+
+similarTracksDecoder : Decoder (List SimilarTrack)
+similarTracksDecoder =
+ D.at [ "data", "similar_tracks" ] (D.list similarTrackDecoder)
+
+
+similarTrackDecoder : Decoder SimilarTrack
+similarTrackDecoder =
+ D.map4 SimilarTrack
+ (D.field "artist" D.string)
+ (D.field "track" D.string)
+ (D.maybe (D.field "score" D.float))
+ (D.maybe (D.field "video_uri" D.string))
diff --git a/src/Client.elm b/src/Client.elm
@@ -1,1419 +1,18 @@
-port module Client exposing (main)
+module Client exposing (main)
import Browser
-import Dict exposing (Dict)
-import Html exposing (Html, a, button, div, h1, h2, img, input, li, p, span, strong, text, ul)
-import Html.Attributes as Attr exposing (class, disabled, href, placeholder, src, style, target, type_, value)
-import Html.Events exposing (on, onClick, onInput)
-import Http
-import Json.Decode as D exposing (Decoder)
-import List
-import Maybe
-import Set exposing (Set)
-import String
-import Task
-import Time
-import Url
-
-
-port pushUrl : String -> Cmd msg
-
-
-type alias UserInfo =
- { slug : String
- , name : String
- }
-
-
-type alias Flags =
- { search : String
- , userSlug : String
- , allUsers : List UserInfo
- }
+import State exposing (init, subscriptions, update)
+import Types exposing (Flags, Model, Msg(..))
+import View exposing (view)
main : Program Flags Model Msg
main =
- Browser.element
+ Browser.application
{ init = init
+ , onUrlRequest = UrlRequested
+ , onUrlChange = UrlChanged
, update = update
, view = view
, subscriptions = subscriptions
}
-
-
-
--- TYPES
-
-
-type Tab
- = ListensTab
- | StatsTab
- | AboutTab
-
-
-type Period
- = AllTime
- | LastDays Int
- | CustomRange String String
-
-
-type alias ActiveFilter =
- { field : String
- , value : String
- }
-
-
-type alias Listen =
- { trackName : Maybe String
- , artistName : Maybe String
- , releaseName : Maybe String
- , listenedAt : Maybe Int
- , genre : Maybe String
- , label : Maybe String
- , releaseMbid : Maybe String
- , caaReleaseMbid : Maybe String
- }
-
-
-type alias StatsEntry =
- { name : String
- , count : Int
- }
-
-
-type alias Stats =
- { genres : List StatsEntry
- , labels : List StatsEntry
- , years : List StatsEntry
- , artists : List StatsEntry
- , tracks : List StatsEntry
- }
-
-
-type alias SimilarTrack =
- { artist : String
- , track : String
- , score : Maybe Float
- , videoUri : Maybe String
- }
-
-
-type SimilarState
- = SimilarLoading
- | SimilarLoaded (List SimilarTrack)
- | SimilarError String
-
-
-
--- MODEL
-
-
-type alias Model =
- { listens : List Listen
- , stats : Maybe Stats
- , error : Maybe String
- , loading : Bool
- , currentTime : Maybe Time.Posix
- , failedCovers : Set String
- , hoveredCover : Maybe Int
- , expandedSections : Set String
- , loadedSections : Set String
- , offset : Int
- , limit : Int
- , activeTab : Tab
- , activeFilter : Maybe ActiveFilter
- , statsPeriod : Period
- , customInput : String
- , showCustomInput : Bool
- , customError : Maybe String
- , userSlug : String
- , similarStates : Dict String SimilarState
- , allUsers : List UserInfo
- , searchInput : String
- , activeSearch : Maybe String
- }
-
-
-init : Flags -> ( Model, Cmd Msg )
-init flags =
- let
- page =
- parsePageParam flags.search
-
- offset =
- max 0 ((page - 1) * 25)
- in
- ( { listens = []
- , stats = Nothing
- , error = Nothing
- , loading = True
- , currentTime = Nothing
- , failedCovers = Set.empty
- , hoveredCover = Nothing
- , expandedSections = Set.empty
- , loadedSections = Set.empty
- , offset = offset
- , limit = 25
- , activeTab = ListensTab
- , activeFilter = Nothing
- , statsPeriod = AllTime
- , customInput = ""
- , showCustomInput = False
- , customError = Nothing
- , userSlug = flags.userSlug
- , similarStates = Dict.empty
- , allUsers = flags.allUsers
- , searchInput = ""
- , activeSearch = Nothing
- }
- , Cmd.batch
- [ fetchListens flags.userSlug 25 offset Nothing Nothing
- , Task.perform GotTime Time.now
- ]
- )
-
-
-parsePageParam : String -> Int
-parsePageParam search =
- let
- s =
- if String.startsWith "?" search then
- String.dropLeft 1 search
-
- else
- search
- in
- s
- |> String.split "&"
- |> List.filterMap
- (\pair ->
- case String.split "=" pair of
- [ "page", v ] ->
- String.toInt v
-
- _ ->
- Nothing
- )
- |> List.head
- |> Maybe.withDefault 1
-
-
-
--- MSG
-
-
-type Msg
- = GotListens (Result Http.Error (List Listen))
- | GotStats (Result Http.Error Stats)
- | GotSectionData String (Result Http.Error (List StatsEntry))
- | Tick Time.Posix
- | GotTime Time.Posix
- | ImageError String
- | NextPage
- | PrevPage
- | SwitchTab Tab
- | SetStatsPeriod Period
- | OpenCustomInput
- | UpdateCustomInput String
- | ApplyCustomPeriod
- | FilterBy String String
- | ClearFilter
- | HoverCover Int
- | UnhoverCover
- | ExpandSection String
- | ShowAllSection String
- | CollapseSection String
- | FetchSimilar String String
- | FetchSimilarTracks String String (Result Http.Error (List SimilarTrack))
- | UpdateSearchInput String
- | SubmitSearch
- | ClearSearch
-
-
-
--- UPDATE
-
-
-update : Msg -> Model -> ( Model, Cmd Msg )
-update msg model =
- case msg of
- Tick time ->
- if not model.loading then
- ( { model | currentTime = Just time, loading = True }
- , fetchListens model.userSlug model.limit model.offset model.activeFilter model.activeSearch
- )
-
- else
- ( { model | currentTime = Just time }, Cmd.none )
-
- GotTime time ->
- ( { model | currentTime = Just time }, Cmd.none )
-
- GotListens result ->
- let
- newModel =
- case result of
- Err err ->
- { model | loading = False, error = Just (httpErrorToString err) }
-
- Ok listens ->
- { model | loading = False, listens = listens, error = Nothing }
- in
- ( newModel, Task.perform GotTime Time.now )
-
- GotStats result ->
- case result of
- Err err ->
- ( { model | error = Just (httpErrorToString err) }, Cmd.none )
-
- Ok stats ->
- ( { model | stats = Just stats }, Cmd.none )
-
- GotSectionData section result ->
- case result of
- Err err ->
- ( { model | error = Just (httpErrorToString err) }, Cmd.none )
-
- Ok entries ->
- ( { model
- | expandedSections = Set.insert section model.expandedSections
- , loadedSections = Set.insert section model.loadedSections
- , stats = Maybe.map (patchStatSection section entries) model.stats
- }
- , Cmd.none
- )
-
- ImageError url ->
- ( { model | failedCovers = Set.insert url model.failedCovers }, Cmd.none )
-
- NextPage ->
- let
- newOffset =
- model.offset + model.limit
-
- page =
- newOffset // model.limit + 1
- in
- ( { model | offset = newOffset, loading = True }
- , Cmd.batch
- [ fetchListens model.userSlug model.limit newOffset model.activeFilter model.activeSearch
- , pushUrl ("?page=" ++ String.fromInt page)
- ]
- )
-
- PrevPage ->
- let
- newOffset =
- max 0 (model.offset - model.limit)
-
- page =
- newOffset // model.limit + 1
- in
- ( { model | offset = newOffset, loading = True }
- , Cmd.batch
- [ fetchListens model.userSlug model.limit newOffset model.activeFilter model.activeSearch
- , pushUrl ("?page=" ++ String.fromInt page)
- ]
- )
-
- SwitchTab tab ->
- ( { model | activeTab = tab }
- , case tab of
- StatsTab ->
- if model.stats == Nothing then
- fetchStats model.userSlug model.statsPeriod
-
- else
- Cmd.none
-
- ListensTab ->
- Cmd.none
-
- AboutTab ->
- Cmd.none
- )
-
- SetStatsPeriod period ->
- ( { model
- | statsPeriod = period
- , stats = Nothing
- , expandedSections = Set.empty
- , loadedSections = Set.empty
- , showCustomInput = False
- }
- , fetchStats model.userSlug period
- )
-
- OpenCustomInput ->
- let
- prefill =
- case model.statsPeriod of
- CustomRange from to ->
- from ++ " " ++ to
-
- _ ->
- model.customInput
- in
- ( { model | showCustomInput = True, customInput = prefill, customError = Nothing }
- , Cmd.none
- )
-
- UpdateCustomInput str ->
- ( { model | customInput = str, customError = Nothing }, Cmd.none )
-
- ApplyCustomPeriod ->
- let
- parts =
- model.customInput
- |> String.split " "
- |> List.filter (not << String.isEmpty)
- in
- case parts of
- [ from, to ] ->
- if String.length from /= 10 || String.length to /= 10 then
- ( { model | customError = Just "Dates must be in YYYY-MM-DD format" }, Cmd.none )
-
- else if from > to then
- ( { model | customError = Just "'from' must be before 'to'" }, Cmd.none )
-
- else
- let
- period =
- CustomRange from to
- in
- ( { model
- | statsPeriod = period
- , stats = Nothing
- , expandedSections = Set.empty
- , loadedSections = Set.empty
- , showCustomInput = False
- , customError = Nothing
- }
- , fetchStats model.userSlug period
- )
-
- _ ->
- ( { model | customError = Just "Enter two dates separated by a space" }, Cmd.none )
-
- FilterBy field value ->
- let
- filter =
- Just { field = field, value = value }
- in
- ( { model | activeFilter = filter, activeSearch = Nothing, searchInput = "", offset = 0, activeTab = ListensTab, loading = True }
- , Cmd.batch
- [ fetchListens model.userSlug model.limit 0 filter Nothing
- , pushUrl "?page=1"
- ]
- )
-
- ClearFilter ->
- ( { model | activeFilter = Nothing, offset = 0, loading = True }
- , Cmd.batch
- [ fetchListens model.userSlug model.limit 0 Nothing model.activeSearch
- , pushUrl "?page=1"
- ]
- )
-
- UpdateSearchInput str ->
- ( { model | searchInput = str }, Cmd.none )
-
- SubmitSearch ->
- let
- q =
- String.trim model.searchInput
- in
- if String.isEmpty q then
- ( { model | activeSearch = Nothing, offset = 0, loading = True }
- , Cmd.batch
- [ fetchListens model.userSlug model.limit 0 Nothing Nothing
- , pushUrl "?page=1"
- ]
- )
-
- else
- ( { model | activeSearch = Just q, activeFilter = Nothing, offset = 0, loading = True }
- , Cmd.batch
- [ fetchListens model.userSlug model.limit 0 Nothing (Just q)
- , pushUrl "?page=1"
- ]
- )
-
- ClearSearch ->
- ( { model | searchInput = "", activeSearch = Nothing, offset = 0, loading = True }
- , Cmd.batch
- [ fetchListens model.userSlug model.limit 0 Nothing Nothing
- , pushUrl "?page=1"
- ]
- )
-
- HoverCover idx ->
- ( { model | hoveredCover = Just idx }, Cmd.none )
-
- UnhoverCover ->
- ( { model | hoveredCover = Nothing }, Cmd.none )
-
- ExpandSection section ->
- ( { model | expandedSections = Set.insert section model.expandedSections }, Cmd.none )
-
- ShowAllSection section ->
- ( model, fetchSectionData model.userSlug model.statsPeriod section )
-
- CollapseSection section ->
- ( { model
- | expandedSections = Set.remove section model.expandedSections
- , loadedSections = Set.remove section model.loadedSections
- }
- , Cmd.none
- )
-
- FetchSimilar artist track ->
- let
- key =
- artist ++ "\t" ++ track
- in
- if Dict.member key model.similarStates then
- ( { model | similarStates = Dict.remove key model.similarStates }, Cmd.none )
-
- else
- ( { model | similarStates = Dict.insert key SimilarLoading model.similarStates }
- , fetchSimilarTracks artist track
- )
-
- FetchSimilarTracks artist track result ->
- let
- key =
- artist ++ "\t" ++ track
-
- newStates =
- case result of
- Ok tracks ->
- Dict.insert key (SimilarLoaded tracks) model.similarStates
-
- Err err ->
- Dict.insert key (SimilarError (httpErrorToString err)) model.similarStates
- in
- ( { model | similarStates = newStates }, Cmd.none )
-
-
-patchStatSection : String -> List StatsEntry -> Stats -> Stats
-patchStatSection section entries stats =
- case section of
- "artist" ->
- { stats | artists = entries }
-
- "track" ->
- { stats | tracks = entries }
-
- "genre" ->
- { stats | genres = entries }
-
- "label" ->
- { stats | labels = entries }
-
- "year" ->
- { stats | years = entries }
-
- _ ->
- stats
-
-
-
--- SUBSCRIPTIONS
-
-
-subscriptions : Model -> Sub Msg
-subscriptions _ =
- Time.every 30000 Tick
-
-
-
--- HTTP
-
-
-fetchListens : String -> Int -> Int -> Maybe ActiveFilter -> Maybe String -> Cmd Msg
-fetchListens userSlug limit offset mFilter mSearch =
- let
- filterParams =
- case mFilter of
- Nothing ->
- ""
-
- Just { field, value } ->
- "&filterField=" ++ field ++ "&filterValue=" ++ Url.percentEncode value
-
- searchParam =
- case mSearch of
- Nothing ->
- ""
-
- Just q ->
- "&search=" ++ Url.percentEncode q
-
- url =
- "/proxy?user=" ++ userSlug ++ "&limit=" ++ String.fromInt limit ++ "&offset=" ++ String.fromInt offset ++ filterParams ++ searchParam
- in
- Http.get
- { url = url
- , expect = Http.expectJson GotListens listensDecoder
- }
-
-
-fetchStats : String -> Period -> Cmd Msg
-fetchStats userSlug period =
- Http.get
- { url = statsUrl userSlug period Nothing
- , expect = Http.expectJson GotStats statsDecoder
- }
-
-
-fetchSectionData : String -> Period -> String -> Cmd Msg
-fetchSectionData userSlug period section =
- Http.get
- { url = statsUrl userSlug period (Just section)
- , expect = Http.expectJson (GotSectionData section) (sectionEntriesDecoder section)
- }
-
-
-statsUrl : String -> Period -> Maybe String -> String
-statsUrl userSlug period mSection =
- let
- periodPart =
- case period of
- AllTime ->
- ""
-
- LastDays n ->
- "&period=" ++ String.fromInt n
-
- CustomRange from to ->
- "&from=" ++ from ++ "&to=" ++ to
-
- sectionPart =
- case mSection of
- Nothing ->
- ""
-
- Just sec ->
- "§ion=" ++ sec
- in
- "/stats?user=" ++ userSlug ++ periodPart ++ sectionPart
-
-
-fetchSimilarTracks : String -> String -> Cmd Msg
-fetchSimilarTracks artist track =
- Http.get
- { url = "/similar?artist=" ++ Url.percentEncode artist ++ "&track=" ++ Url.percentEncode track
- , expect = Http.expectJson (FetchSimilarTracks artist track) similarTracksDecoder
- }
-
-
-httpErrorToString : Http.Error -> String
-httpErrorToString err =
- case err of
- Http.BadUrl url ->
- "Bad URL: " ++ url
-
- Http.Timeout ->
- "Request timed out"
-
- Http.NetworkError ->
- "Network error"
-
- Http.BadStatus status ->
- "Server error: " ++ String.fromInt status
-
- Http.BadBody body ->
- "JSON decode error: " ++ body
-
-
-
--- DECODERS
-
-
-listensDecoder : Decoder (List Listen)
-listensDecoder =
- D.at [ "payload", "listens" ] (D.list listenDecoder)
-
-
-listenDecoder : Decoder Listen
-listenDecoder =
- D.map2
- (\meta listenedAt ->
- { trackName = meta.trackName
- , artistName = meta.artistName
- , releaseName = meta.releaseName
- , listenedAt = listenedAt
- , genre = meta.genre
- , label = meta.label
- , releaseMbid = meta.releaseMbid
- , caaReleaseMbid = meta.caaReleaseMbid
- }
- )
- (D.field "track_metadata" trackMetaDecoder)
- (D.maybe (D.field "listened_at" D.int))
-
-
-type alias TrackMeta =
- { trackName : Maybe String
- , artistName : Maybe String
- , releaseName : Maybe String
- , genre : Maybe String
- , releaseMbid : Maybe String
- , caaReleaseMbid : Maybe String
- , label : Maybe String
- }
-
-
-trackMetaDecoder : Decoder TrackMeta
-trackMetaDecoder =
- D.map7 TrackMeta
- (D.maybe (D.field "track_name" D.string))
- (D.maybe (D.field "artist_name" D.string))
- (D.maybe (D.field "release_name" D.string))
- (D.maybe (D.field "genre" D.string))
- (D.maybe (D.at [ "mbid_mapping", "release_mbid" ] D.string))
- (D.maybe (D.at [ "mbid_mapping", "caa_release_mbid" ] D.string))
- (D.maybe (D.field "label" D.string))
-
-
-statsDecoder : Decoder Stats
-statsDecoder =
- D.map5 Stats
- (D.field "genres" (D.list entryDecoder))
- (D.field "labels" (D.list entryDecoder))
- (D.field "years" (D.list entryDecoder))
- (D.field "artists" (D.list entryDecoder))
- (D.field "tracks" (D.list entryDecoder))
-
-
-entryDecoder : Decoder StatsEntry
-entryDecoder =
- D.map2 StatsEntry
- (D.field "name" D.string)
- (D.field "count" D.int)
-
-
-sectionEntriesDecoder : String -> Decoder (List StatsEntry)
-sectionEntriesDecoder section =
- D.map
- (\stats ->
- case section of
- "artist" ->
- stats.artists
-
- "track" ->
- stats.tracks
-
- "genre" ->
- stats.genres
-
- "label" ->
- stats.labels
-
- "year" ->
- stats.years
-
- _ ->
- []
- )
- statsDecoder
-
-
-similarTracksDecoder : Decoder (List SimilarTrack)
-similarTracksDecoder =
- D.at [ "data", "similar_tracks" ] (D.list similarTrackDecoder)
-
-
-similarTrackDecoder : Decoder SimilarTrack
-similarTrackDecoder =
- D.map4 SimilarTrack
- (D.field "artist" D.string)
- (D.field "track" D.string)
- (D.maybe (D.field "score" D.float))
- (D.maybe (D.field "video_uri" D.string))
-
-
-
--- VIEW
-
-
-view : Model -> Html Msg
-view model =
- div [ class "container" ]
- [ h1 [] [ text "scrobbler" ]
- , div [ class "tabs" ]
- [ a
- [ class
- ("tab-btn"
- ++ (if model.activeTab == ListensTab then
- " active"
-
- else
- ""
- )
- )
- , href
- (if model.userSlug == "" then
- "/"
-
- else
- "/u/" ++ model.userSlug
- )
- ]
- [ text "listens" ]
- , button
- [ class
- ("tab-btn"
- ++ (if model.activeTab == StatsTab then
- " active"
-
- else
- ""
- )
- )
- , onClick (SwitchTab StatsTab)
- ]
- [ text "stats" ]
- , button
- [ class
- ("tab-btn"
- ++ (if model.activeTab == AboutTab then
- " active"
-
- else
- ""
- )
- )
- , onClick (SwitchTab AboutTab)
- ]
- [ text "about" ]
- ]
- , case model.activeTab of
- ListensTab ->
- div []
- [ div [ class "search-bar" ]
- [ input
- [ type_ "text"
- , class "search-input"
- , placeholder "search by track, artist, album or label"
- , value model.searchInput
- , onInput UpdateSearchInput
- , onEnter SubmitSearch
- ]
- []
- , button [ class "search-btn", onClick SubmitSearch ] [ text "search" ]
- , case model.activeSearch of
- Just _ ->
- button [ class "filter-clear", onClick ClearSearch ] [ text "✕ clear" ]
-
- Nothing ->
- text ""
- ]
- , case model.activeFilter of
- Nothing ->
- text ""
-
- Just { field, value } ->
- div [ class "filter-banner" ]
- [ span [ class "filter-label" ]
- [ text (field ++ ": ")
- , strong [] [ text value ]
- ]
- , button [ class "filter-clear", onClick ClearFilter ]
- [ text "✕ clear" ]
- ]
- , renderContent model
- , div [ class "pagination" ]
- [ button
- [ class "page-btn"
- , disabled (model.offset == 0 || model.loading)
- , onClick PrevPage
- ]
- [ text "Previous" ]
- , div [ class "page-indicator" ]
- [ text ("Page " ++ String.fromInt (model.offset // model.limit + 1)) ]
- , button
- [ class "page-btn"
- , disabled (List.length model.listens < model.limit || model.loading)
- , onClick NextPage
- ]
- [ text "Next" ]
- ]
- ]
-
- StatsTab ->
- div []
- [ renderPeriodSelector model.statsPeriod model.showCustomInput model.customInput model.customError
- , renderStatsView model.expandedSections model.loadedSections model.stats
- ]
-
- AboutTab ->
- renderAboutView model.userSlug model.allUsers
- ]
-
-
-renderContent : Model -> Html Msg
-renderContent model =
- if model.loading && List.isEmpty model.listens then
- ul [] [ li [ class "loading" ] [ text "⏳" ] ]
-
- else
- case model.error of
- Just err ->
- ul [] [ li [ class "error" ] [ text err ] ]
-
- Nothing ->
- div [ class "tracks-with-similar" ]
- (List.indexedMap
- (\idx listen ->
- let
- artist =
- Maybe.withDefault "" listen.artistName
-
- trackName =
- Maybe.withDefault "" listen.trackName
-
- key =
- artist ++ "\t" ++ trackName
- in
- div [ class "track-with-similar-container" ]
- [ ul [ class "track-item" ]
- [ renderListen model.userSlug model.currentTime model.failedCovers model.hoveredCover model.similarStates idx listen ]
- , renderSimilarPanel model.similarStates key
- ]
- )
- model.listens
- )
-
-
-renderListen : String -> Maybe Time.Posix -> Set String -> Maybe Int -> Dict String SimilarState -> Int -> Listen -> Html Msg
-renderListen userSlug currentTime failedCovers hoveredCover similarStates idx listen =
- let
- artist =
- Maybe.withDefault "" listen.artistName
-
- trackName =
- Maybe.withDefault "" listen.trackName
-
- release =
- Maybe.withDefault "" listen.releaseName
-
- key =
- artist ++ "\t" ++ trackName
-
- mbid =
- case listen.caaReleaseMbid of
- Just m ->
- Just m
-
- Nothing ->
- listen.releaseMbid
-
- coverUrl =
- "/cover?user="
- ++ userSlug
- ++ "&artist="
- ++ Url.percentEncode artist
- ++ "&release="
- ++ Url.percentEncode release
- ++ (case mbid of
- Just m ->
- "&mbid=" ++ m
-
- Nothing ->
- ""
- )
-
- isZoomed =
- hoveredCover == Just idx
-
- isActive =
- Dict.member key similarStates
- in
- li [ class "success" ]
- [ div [ class "track-info" ]
- [ div [ class "track-name" ]
- [ button [ class "track-link", onClick (FilterBy "track" (Maybe.withDefault "Unknown Track" listen.trackName)) ] [ text (Maybe.withDefault "Unknown Track" listen.trackName) ] ]
- , div [ class "track-artist" ] [ button [ class "artist-link", onClick (FilterBy "artist" artist) ] [ text artist ] ]
- , div [ class "track-time" ]
- [ span []
- (button [ class "album-link", onClick (FilterBy "album" release) ] [ text release ]
- :: (case listen.label of
- Just l ->
- [ text " • "
- , button [ class "label-link", onClick (FilterBy "label" l) ] [ text l ]
- ]
-
- Nothing ->
- []
- )
- ++ [ text (" • " ++ timeAgo currentTime listen.listenedAt) ]
- )
- ]
- ]
- , div [ class "cover-wrapper" ]
- [ if Set.member coverUrl failedCovers then
- text ""
-
- else
- img
- [ class
- ("track-cover"
- ++ (if isZoomed then
- " zoomed"
-
- else
- ""
- )
- )
- , src coverUrl
- , Attr.alt release
- , on "error" (D.succeed (ImageError coverUrl))
- , onClick
- (if isZoomed then
- UnhoverCover
-
- else
- HoverCover idx
- )
- ]
- []
- , case listen.genre of
- Just g ->
- div [ class "genre-tag" ] [ text g ]
-
- Nothing ->
- text ""
- , if artist /= "" && trackName /= "" then
- button
- [ class
- ("similar-btn"
- ++ (if isActive then
- " active"
-
- else
- ""
- )
- )
- , onClick (FetchSimilar artist trackName)
- ]
- [ text "similar" ]
-
- else
- text ""
- ]
- ]
-
-
-renderSimilarPanel : Dict String SimilarState -> String -> Html Msg
-renderSimilarPanel similarStates key =
- case Dict.get key similarStates of
- Nothing ->
- text ""
-
- Just SimilarLoading ->
- div [ class "similar-panel" ]
- [ div [ class "similar-loading" ] [ text "⏳" ] ]
-
- Just (SimilarError err) ->
- div [ class "similar-panel" ]
- [ div [ class "similar-error" ] [ text err ] ]
-
- Just (SimilarLoaded tracks) ->
- div [ class "similar-panel" ]
- [ if List.isEmpty tracks then
- div [ class "similar-empty" ] [ text "no similar songs found" ]
-
- else
- div [] (List.map renderSimilarTrack tracks)
- ]
-
-
-renderSimilarTrack : SimilarTrack -> Html Msg
-renderSimilarTrack track =
- div [ class "similar-track" ]
- [ div [ class "similar-track-info" ]
- [ div [ class "similar-track-name" ] [ text track.track ]
- , div [ class "similar-track-artist" ] [ text track.artist ]
- ]
- , case track.score of
- Just score ->
- span [ class "similar-score" ]
- [ text (String.fromInt (round (score * 100)) ++ "%") ]
-
- Nothing ->
- text ""
- , case track.videoUri of
- Just link ->
- a [ class "similar-link", href link, target "_blank" ]
- [ text "▶" ]
-
- Nothing ->
- text ""
- ]
-
-
-renderStatsView : Set String -> Set String -> Maybe Stats -> Html Msg
-renderStatsView expandedSections loadedSections mStats =
- case mStats of
- Nothing ->
- div [ class "loading" ] [ text "⏳" ]
-
- Just stats ->
- div []
- [ renderStatSection expandedSections loadedSections (Just "artist") "top artists" stats.artists
- , renderStatSection expandedSections loadedSections Nothing "top tracks" stats.tracks
- , renderStatSection expandedSections loadedSections (Just "genre") "genres" stats.genres
- , renderStatSection expandedSections loadedSections (Just "label") "labels" stats.labels
- , renderStatSection expandedSections loadedSections (Just "year") "years" stats.years
- ]
-
-
-renderStatSection : Set String -> Set String -> Maybe String -> String -> List StatsEntry -> Html Msg
-renderStatSection expandedSections loadedSections mField title entries =
- let
- sectionKey =
- Maybe.withDefault title mField
-
- expanded =
- Set.member sectionKey expandedSections
-
- loaded =
- Set.member sectionKey loadedSections
-
- visible =
- if loaded then
- entries
-
- else if expanded then
- List.take 50 entries
-
- else
- List.take 10 entries
-
- maxCount =
- entries
- |> List.map .count
- |> List.maximum
- |> Maybe.withDefault 1
-
- n =
- List.length entries
-
- footer =
- if loaded then
- if n > 10 then
- button [ class "show-all-btn", onClick (CollapseSection sectionKey) ] [ text "show less" ]
-
- else
- text ""
-
- else if expanded then
- if n >= 50 then
- span []
- [ button [ class "show-all-btn", onClick (ShowAllSection sectionKey) ] [ text "show all" ]
- , text " · "
- , button [ class "show-all-btn", onClick (CollapseSection sectionKey) ] [ text "show less" ]
- ]
-
- else
- button [ class "show-all-btn", onClick (CollapseSection sectionKey) ] [ text "show less" ]
-
- else if n > 10 then
- button [ class "show-all-btn", onClick (ExpandSection sectionKey) ] [ text "show more" ]
-
- else
- text ""
- in
- div [ class "stats-section" ]
- [ h2 [] [ text title ]
- , if List.isEmpty entries then
- div [ class "stats-empty" ] [ text "beyond here lies nothing" ]
-
- else
- ul [] (List.map (renderStatEntry maxCount mField) visible)
- , footer
- ]
-
-
-renderStatEntry : Int -> Maybe String -> StatsEntry -> Html Msg
-renderStatEntry maxCount mField entry =
- let
- barPct =
- entry.count * 100 // maxCount
-
- rowAttrs =
- case mField of
- Just field ->
- [ class "stat-row clickable", onClick (FilterBy field entry.name) ]
-
- Nothing ->
- [ class "stat-row" ]
- in
- li rowAttrs
- [ div [ class "stat-bar", style "width" (String.fromInt barPct ++ "%") ] []
- , span [ class "stat-name" ] [ text entry.name ]
- , span [ class "stat-count" ] [ text (String.fromInt entry.count) ]
- ]
-
-
-renderPeriodSelector : Period -> Bool -> String -> Maybe String -> Html Msg
-renderPeriodSelector current showInput customVal mError =
- let
- isCustom =
- case current of
- CustomRange _ _ ->
- True
-
- _ ->
- False
-
- namedBtn target label =
- button
- [ class
- ("period-btn"
- ++ (if current == target then
- " active"
-
- else
- ""
- )
- )
- , onClick (SetStatsPeriod target)
- ]
- [ text label ]
-
- customBtn =
- button
- [ class
- ("period-btn"
- ++ (if isCustom then
- " active"
-
- else
- ""
- )
- )
- , onClick OpenCustomInput
- ]
- [ text "custom" ]
-
- daysBtn n =
- let
- label =
- case n of
- 7 ->
- "1w"
-
- 14 ->
- "2w"
-
- 30 ->
- "1m"
-
- 90 ->
- "3m"
-
- 180 ->
- "6m"
-
- 365 ->
- "1y"
-
- _ ->
- String.fromInt n ++ "d"
- in
- button
- [ class
- ("period-btn"
- ++ (if current == LastDays n then
- " active"
-
- else
- ""
- )
- )
- , onClick (SetStatsPeriod (LastDays n))
- ]
- [ text label ]
- in
- div []
- [ div [ class "period-selector" ]
- ([ namedBtn AllTime "all time", customBtn ]
- ++ List.map daysBtn [ 7, 14, 30, 90, 180, 365 ]
- )
- , if showInput || isCustom then
- div []
- [ div [ class "custom-range" ]
- [ input
- [ type_ "text"
- , class
- ("custom-range-input"
- ++ (if mError /= Nothing then
- " error"
-
- else
- ""
- )
- )
- , placeholder "2023-01-01 2026-01-01"
- , value customVal
- , onInput UpdateCustomInput
- ]
- []
- , button [ class "period-btn", onClick ApplyCustomPeriod ]
- [ text "apply" ]
- ]
- , case mError of
- Just err ->
- div [ class "custom-range-error" ] [ text err ]
-
- Nothing ->
- text ""
- ]
-
- else
- text ""
- ]
-
-
-onEnter : msg -> Html.Attribute msg
-onEnter msg =
- on "keydown"
- (D.field "key" D.string
- |> D.andThen
- (\key ->
- if key == "Enter" then
- D.succeed msg
-
- else
- D.fail "not enter"
- )
- )
-
-
-
--- HELPERS
-
-
-timeAgo : Maybe Time.Posix -> Maybe Int -> String
-timeAgo mNow mTimestamp =
- case ( mNow, mTimestamp ) of
- ( Just now, Just ts ) ->
- let
- nowSecs =
- Time.posixToMillis now // 1000
-
- diff =
- nowSecs - ts
- in
- if diff < 60 then
- "just now"
-
- else if diff < 3600 then
- let
- mins =
- diff // 60
- in
- String.fromInt mins
- ++ " minute"
- ++ (if mins > 1 then
- "s"
-
- else
- ""
- )
- ++ " ago"
-
- else if diff < 86400 then
- let
- hours =
- diff // 3600
- in
- String.fromInt hours
- ++ " hour"
- ++ (if hours > 1 then
- "s"
-
- else
- ""
- )
- ++ " ago"
-
- else
- let
- days =
- diff // 86400
- in
- String.fromInt days
- ++ " day"
- ++ (if days > 1 then
- "s"
-
- else
- ""
- )
- ++ " ago"
-
- _ ->
- "unknown time"
-
-
-renderAboutView : String -> List UserInfo -> Html Msg
-renderAboutView currentSlug allUsers =
- let
- otherUsers =
- List.filter (\u -> u.slug /= currentSlug) allUsers
-
- userLink { slug, name } =
- let
- url =
- if slug == "" then
- "/"
-
- else
- "/u/" ++ slug
- in
- li [] [ a [ href url ] [ text name ] ]
-
- extLink url label =
- a [ href url, target "_blank", class "about-link" ] [ text label ]
- in
- div []
- [ p [ class "about-lead" ]
- [ text "corpus is a self-hosted listen history proxy that syncs scrobbles from "
- , extLink "https://listenbrainz.org" "ListenBrainz"
- , text " and "
- , extLink "https://www.last.fm" "Last.fm."
- ]
- , div [ class "stats-section" ]
- [ h2 [] [ text "features" ]
- , ul [ class "about-list" ]
- [ li [] [ text "searchable listen history with pagination" ]
- , li [] [ text "stats by artist, track, label, year, and genre" ]
- , li [] [ text "filter listens by label, artist, genre, or year" ]
- , li [] [ text "cover art from Cover Art Archive, Last.fm, and Discogs" ]
- , li [] [ text "similar track discovery via cosine.club" ]
- , li [] [ text "metadata enrichment via MusicBrainz, Last.fm, and Discogs" ]
- ]
- ]
- , div [ class "stats-section" ]
- [ h2 [] [ text "links" ]
- , p [ class "about-meta" ]
- [ div [] [ extLink "https://instagram.com/counterpoint303" "counterpoint" ]
- , div [] [ extLink "https://github.com/mtmn/corpus" "github repo" ]
- , div [] [ extLink "https://mtmn.name" "mtmn.name" ]
- ]
- ]
- , if List.isEmpty otherUsers then
- text ""
-
- else
- div [ class "stats-section" ]
- [ h2 [] [ text "friends" ]
- , ul [ class "about-users" ]
- (List.map userLink otherUsers)
- ]
- ]
diff --git a/src/Config.purs b/src/Config.purs
@@ -33,7 +33,6 @@ type UserConfig =
, coverCacheEnabled :: Boolean
, backupEnabled :: Boolean
, backupIntervalHours :: Int
- , initialSync :: Boolean
}
type UserEntry =
@@ -172,7 +171,6 @@ decodeUserConfig json = do
coverCacheEnabled <- mapLeft show $ obj .: "coverCacheEnabled"
backupEnabled <- mapLeft show $ obj .: "backupEnabled"
backupIntervalHours <- mapLeft show $ obj .: "backupIntervalHours"
- initialSync <- mapLeft show $ obj .: "initialSync"
pure
{ listenbrainzUser
, lastfmUser
@@ -189,5 +187,4 @@ decodeUserConfig json = do
, coverCacheEnabled
, backupEnabled
, backupIntervalHours
- , initialSync
}
diff --git a/src/Cosine.purs b/src/Cosine.purs
@@ -0,0 +1,126 @@
+module Cosine
+ ( fetchCosineSimilar
+ , serveSimilar
+ ) where
+
+import Prelude
+
+import Config (UserConfig)
+import Control.Monad.Error.Class (throwError)
+import Data.Array ((!!))
+import Data.Either (Either(..), hush)
+import Data.Argonaut (parseJson)
+import Data.Argonaut.Core (toArray, toObject, toString)
+import Data.Maybe (Maybe(..), fromMaybe)
+import Effect (Effect)
+import Effect.Aff (Aff, launchAff_, try)
+import Effect.Class (liftEffect)
+import Effect.Exception as Exception
+import Fetch (fetch, Method(GET))
+import Foreign.Object as Object
+import JSURI (encodeURIComponent)
+import Log as Log
+import Metrics as Metrics
+import Node.Encoding (Encoding(UTF8))
+import Node.HTTP.OutgoingMessage (setHeader, toWriteable)
+import Node.HTTP.ServerResponse (setStatusCode, toOutgoingMessage)
+import Node.HTTP.Types (ServerResponse)
+import Node.Stream (end, writeString)
+import Web.URL (URL)
+import Web.URL.URLSearchParams as URLSearchParams
+import Web.URL as URL
+
+type Response = ServerResponse
+
+getQueryParam :: String -> URL -> Maybe String
+getQueryParam key url = URLSearchParams.get key (URL.searchParams url)
+
+fetchCosineSimilar :: String -> UserConfig -> String -> Aff String
+fetchCosineSimilar slug cfg query = do
+ let apiKey = fromMaybe "" cfg.cosineApiKey
+ if apiKey == "" then do
+ Log.warn "cosineApiKey not configured for similar tracks"
+ liftEffect $ Metrics.incCosineRequest slug "not_configured"
+ pure "{\"data\":{\"similar_tracks\":[]},\"success\":true}"
+ else do
+ let headers = { "User-Agent": "corpus/1.0 +https://github.com/mtmn/corpus", "Authorization": "Bearer " <> apiKey }
+ let searchUrl = "https://cosine.club/api/v1/search?q=" <> (fromMaybe "" $ encodeURIComponent query) <> "&limit=1"
+ Log.info $ "Cosine Club: searching for: " <> query
+ searchResult <- try $ fetch searchUrl { method: GET, headers: headers }
+ case searchResult of
+ Left err -> do
+ liftEffect $ Metrics.incCosineRequest slug "error"
+ throwError err
+ Right searchRes ->
+ if searchRes.status == 429 then do
+ Log.warn "Cosine Club: rate limited on search"
+ liftEffect $ Metrics.incCosineRequest slug "rate_limited"
+ throwError (Exception.error "Rate limit exceeded")
+ else if searchRes.status /= 200 then do
+ Log.warn $ "Cosine Club: search returned " <> show searchRes.status
+ liftEffect $ Metrics.incCosineRequest slug "error"
+ throwError (Exception.error "Search API error")
+ else do
+ searchBody <- searchRes.text
+ let
+ mTrackId = do
+ json <- hush $ parseJson searchBody
+ obj <- toObject json
+ arr <- Object.lookup "data" obj >>= toArray
+ first <- arr !! 0
+ firstObj <- toObject first
+ Object.lookup "id" firstObj >>= toString
+ case mTrackId of
+ Nothing -> do
+ Log.info $ "Cosine Club: track not indexed: " <> query
+ liftEffect $ Metrics.incCosineRequest slug "not_indexed"
+ pure "{\"data\":{\"similar_tracks\":[]},\"success\":true}"
+ Just trackId -> do
+ let similarUrl = "https://cosine.club/api/v1/tracks/" <> trackId <> "/similar?limit=10"
+ Log.info $ "Cosine Club: fetching similar for ID " <> trackId
+ similarResult <- try $ fetch similarUrl { method: GET, headers: headers }
+ case similarResult of
+ Left err -> do
+ liftEffect $ Metrics.incCosineRequest slug "error"
+ throwError err
+ Right similarRes ->
+ if similarRes.status == 429 then do
+ Log.warn "Cosine Club: rate limited on similar"
+ liftEffect $ Metrics.incCosineRequest slug "rate_limited"
+ throwError (Exception.error "Rate limit exceeded")
+ else if similarRes.status /= 200 then do
+ Log.warn $ "Cosine Club: similar API returned " <> show similarRes.status
+ liftEffect $ Metrics.incCosineRequest slug "error"
+ throwError (Exception.error "Similar API error")
+ else do
+ liftEffect $ Metrics.incCosineRequest slug "success"
+ similarRes.text
+
+serveSimilar
+ :: (Response -> String -> Effect Unit)
+ -> (Response -> Int -> String -> String -> Effect Unit)
+ -> String
+ -> UserConfig
+ -> URL
+ -> Response
+ -> Effect Unit
+serveSimilar serveBadRequest serveError slug cfg url res = do
+ setHeader "Content-Type" "application/json" (toOutgoingMessage res)
+ launchAff_ do
+ let artist = fromMaybe "" (getQueryParam "artist" url)
+ let track = fromMaybe "" (getQueryParam "track" url)
+ if artist == "" || track == "" then
+ liftEffect $ serveBadRequest res "Artist and track parameters are required"
+ else do
+ let query = artist <> " - " <> track
+ result <- try $ fetchCosineSimilar slug cfg query
+ case result of
+ Left err -> do
+ Log.error $ "Cosine Club API error: " <> Exception.message err
+ liftEffect $ serveError res 502 "Bad Gateway" "Failed to fetch similar tracks"
+ Right responseBody ->
+ liftEffect $ do
+ setStatusCode 200 res
+ let w = toWriteable (toOutgoingMessage res)
+ void $ writeString w UTF8 responseBody
+ end w
diff --git a/src/Cover.purs b/src/Cover.purs
@@ -0,0 +1,207 @@
+module Cover
+ ( CoverSource
+ , sanitizeKey
+ , fetchLastfmCoverUrl
+ , fetchDiscogsCoverUrl
+ , coverSources
+ , serveCover
+ ) where
+
+import Prelude
+
+import Config (S3Config, UserConfig, s3ConfigFromUser)
+import S3 (existsInS3, getS3Url, uploadToS3)
+import Control.Monad.Error.Class (throwError)
+import Data.Array ((!!))
+import Data.Either (Either(..))
+import Data.Foldable (foldM)
+import Data.Map as Map
+import Data.Maybe (Maybe(..), fromMaybe)
+import Data.String.CaseInsensitive (CaseInsensitiveString(..))
+import Data.String.Regex (replace, parseFlags)
+import Data.String.Regex.Unsafe (unsafeRegex)
+import Effect (Effect)
+import Effect.Aff (Aff, forkAff, launchAff_, try)
+import Effect.Class (liftEffect)
+import Effect.Exception as Exception
+import Fetch (fetch, Method(GET))
+import Fetch.Argonaut.Json (fromJson)
+import Foreign.Object as Object
+import Data.Argonaut.Core (toArray, toObject, toString)
+import Image (convertToAvif)
+import JSURI (encodeURIComponent)
+import Log as Log
+import Metrics as Metrics
+import Node.Buffer (fromArrayBuffer)
+import Node.HTTP.OutgoingMessage (setHeader, toWriteable)
+import Node.HTTP.ServerResponse (setStatusCode, toOutgoingMessage)
+import Node.HTTP.Types (ServerResponse)
+import Node.Stream (end, write)
+import S3 (existsInS3, getS3Url, uploadToS3)
+import Unsafe.Coerce (unsafeCoerce)
+import Web.URL (URL)
+import Web.URL as URL
+import Web.URL.URLSearchParams as URLSearchParams
+
+type Response = ServerResponse
+
+type CoverSource =
+ { name :: String
+ , s3Key :: String
+ , findUrl :: Aff (Maybe String)
+ }
+
+sanitizeKey :: String -> String
+sanitizeKey = replace re1 "_" >>> replace re2 "_"
+ where
+ re1 = unsafeRegex "[^a-z0-9.-]" (parseFlags "gi")
+ re2 = unsafeRegex "_{2,}" (parseFlags "g")
+
+getQueryParam :: String -> URL -> Maybe String
+getQueryParam key url = URLSearchParams.get key (URL.searchParams url)
+
+fetchLastfmCoverUrl :: UserConfig -> String -> String -> Aff (Maybe String)
+fetchLastfmCoverUrl cfg artist release = case cfg.lastfmApiKey of
+ Nothing ->
+ pure Nothing
+ Just k -> do
+ let
+ searchUrl = "https://ws.audioscrobbler.com/2.0/?method=album.getinfo&artist="
+ <> (fromMaybe "" $ encodeURIComponent artist)
+ <> "&album="
+ <> (fromMaybe "" $ encodeURIComponent release)
+ <> "&format=json&api_key="
+ <> k
+ Log.info $ "Searching Last.fm for: " <> artist <> " - " <> release
+ result <- try $ fetch searchUrl { method: GET }
+ case result of
+ Right fr | fr.status == 200 -> do
+ json <- fromJson fr.json
+ pure $ do
+ obj <- toObject json
+ album <- Object.lookup "album" obj >>= toObject
+ images <- Object.lookup "image" album >>= toArray
+ imgObj <- images !! 2 >>= toObject
+ u <- Object.lookup "#text" imgObj >>= toString
+ if u == "" then Nothing else Just u
+ _ ->
+ pure Nothing
+
+fetchDiscogsCoverUrl :: UserConfig -> String -> String -> Aff (Maybe String)
+fetchDiscogsCoverUrl cfg artist release = case cfg.discogsToken of
+ Nothing ->
+ pure Nothing
+ Just t -> do
+ let
+ queryStr = artist <> " " <> release
+ searchUrl = "https://api.discogs.com/database/search?q="
+ <> (fromMaybe "" $ encodeURIComponent queryStr)
+ <> "&type=release&per_page=1"
+ Log.info $ "Searching Discogs for: " <> queryStr
+ result <- try $ fetch searchUrl { method: GET, headers: { "User-Agent": "corpus/1.0 +https://github.com/mtmn/corpus", "Authorization": "Discogs token=" <> t } }
+ case result of
+ Right fr | fr.status == 200 -> do
+ json <- fromJson fr.json
+ pure $ do
+ obj <- toObject json
+ results <- Object.lookup "results" obj >>= toArray
+ firstResult <- results !! 0 >>= toObject
+ Object.lookup "cover_image" firstResult >>= toString
+ _ ->
+ pure Nothing
+
+coverSources :: String -> String -> String -> UserConfig -> Array CoverSource
+coverSources mbid artist release cfg =
+ let
+ safeArtist = sanitizeKey artist
+ safeRelease = sanitizeKey release
+ in
+ [ { name: "caa"
+ , s3Key: "covers/caa/" <> sanitizeKey mbid <> ".avif"
+ , findUrl:
+ if mbid == "" then pure Nothing
+ else pure $ Just $ "https://coverartarchive.org/release/" <> mbid <> "/front-250"
+ }
+ , { name: "lastfm"
+ , s3Key: "covers/lastfm/" <> safeArtist <> "-" <> safeRelease <> ".avif"
+ , findUrl:
+ if artist == "" || release == "" then pure Nothing
+ else fetchLastfmCoverUrl cfg artist release
+ }
+ , { name: "discogs"
+ , s3Key: "covers/discogs/" <> safeArtist <> "-" <> safeRelease <> ".avif"
+ , findUrl:
+ if artist == "" || release == "" then pure Nothing
+ else fetchDiscogsCoverUrl cfg artist release
+ }
+ ]
+
+serveCover :: (Response -> Effect Unit) -> UserConfig -> String -> URL -> Response -> Aff Unit
+serveCover serveNotFound cfg slug url res = do
+ let
+ mbid = fromMaybe "" (getQueryParam "mbid" url)
+ artist = fromMaybe "" (getQueryParam "artist" url)
+ release = fromMaybe "" (getQueryParam "release" url)
+ s3cfg = s3ConfigFromUser cfg
+
+ served <- foldM (trySource s3cfg) false (coverSources mbid artist release cfg)
+ unless served $ liftEffect $ serveNotFound res
+
+ where
+ trySource _ true _ = pure true
+ trySource s3cfg false { name, s3Key, findUrl } = do
+ cached <- checkS3 s3cfg s3Key
+ if cached then do
+ Log.info $ "Serving " <> name <> " cover from S3: " <> s3Key
+ liftEffect $ Metrics.incCoverRequest slug name "s3_hit"
+ liftEffect $ serveS3Redirect s3cfg s3Key res
+ pure true
+ else do
+ mUrl <- findUrl
+ case mUrl of
+ Nothing ->
+ pure false
+ Just urlStr -> do
+ redirectAndCache s3cfg urlStr s3Key res
+ liftEffect $ Metrics.incCoverRequest slug name "fetch"
+ pure true
+
+ checkS3 s3cfg s3Key
+ | not cfg.coverCacheEnabled = pure false
+ | otherwise = do
+ result <- try $ existsInS3 s3cfg s3Key
+ pure $ case result of
+ Right b -> b
+ Left _ -> false
+
+ serveS3Redirect s3cfg s3Key response = do
+ setStatusCode 302 response
+ setHeader "Location" (getS3Url s3cfg s3Key) (toOutgoingMessage response)
+ end (toWriteable (toOutgoingMessage response))
+
+ -- Redirect the client immediately to the upstream URL, then fetch+convert+cache in background.
+ -- This avoids blocking the response on AVIF conversion (which can take hundreds of ms).
+ redirectAndCache s3cfg urlStr s3Key response = do
+ liftEffect $ do
+ setStatusCode 302 response
+ setHeader "Location" urlStr (toOutgoingMessage response)
+ setHeader "Cache-Control" "public, max-age=3600" (toOutgoingMessage response)
+ end (toWriteable (toOutgoingMessage response))
+ when cfg.coverCacheEnabled $ void $ forkAff do
+ fetchResult <- try $ fetch urlStr { method: GET }
+ case fetchResult of
+ Right fr | fr.status == 200 -> do
+ let
+ isAvif = case Map.lookup (CaseInsensitiveString "content-type") fr.headers of
+ Just ct | ct == "image/avif" -> true
+ _ -> false
+ Log.info $ "caching image (" <> (if isAvif then "already avif" else "needs conversion") <> "): " <> urlStr
+ buf <- fr.arrayBuffer
+ avifBuf <- if isAvif then pure buf else convertToAvif buf
+ uploadResult <- try $ uploadToS3 s3cfg s3Key (unsafeCoerce avifBuf) "image/avif"
+ case uploadResult of
+ Right _ -> Log.info $ "Cached to S3: " <> s3Key
+ Left err -> Log.error $ "S3 upload failed: " <> Exception.message err
+ _ ->
+ Log.warn $ "Background fetch failed for: " <> urlStr
+
diff --git a/src/Image.js b/src/Image.js
@@ -0,0 +1,11 @@
+import sharp from 'sharp';
+
+export const convertToAvifImpl = (buffer) => () =>
+ new Promise((resolve, reject) =>
+ sharp(buffer)
+ .avif()
+ .toBuffer((err, data) => {
+ if (err) return reject(err);
+ resolve(data.buffer.slice(data.byteOffset, data.byteOffset + data.byteLength));
+ })
+ );
diff --git a/src/Image.purs b/src/Image.purs
@@ -0,0 +1,12 @@
+module Image (convertToAvif) where
+
+import Prelude
+import Control.Promise (Promise, toAffE)
+import Effect (Effect)
+import Effect.Aff (Aff)
+import Data.ArrayBuffer.Types (ArrayBuffer)
+
+foreign import convertToAvifImpl :: ArrayBuffer -> Effect (Promise ArrayBuffer)
+
+convertToAvif :: ArrayBuffer -> Aff ArrayBuffer
+convertToAvif = toAffE <<< convertToAvifImpl
diff --git a/src/Main.purs b/src/Main.purs
@@ -3,56 +3,47 @@ module Main where
import Prelude
import Config (AppConfig, UserConfig, UserEntry, loadConfig, s3ConfigFromUser)
+import Control.Monad.Rec.Class (forever)
+import Cover (serveCover)
+import Cosine (serveSimilar)
+import Data.Array (find, length)
+import Data.Either (Either(..))
+import Data.Foldable (for_, traverse_)
+import Data.Int (fromString, toNumber)
+import Data.Maybe (Maybe(..), fromMaybe)
+import Data.String (Pattern(..), stripPrefix)
+import Data.String.Regex (replace, parseFlags)
+import Data.String.Regex.Unsafe (unsafeRegex)
+import Data.Traversable (traverse)
+import Data.Tuple (Tuple(..))
+import Db (Connection, FilterField(..), backupDb, connect, getScrobbles, getStats, initDb, initReleaseMetadata, ping, withTransaction)
import Effect (Effect)
-import Node.EventEmitter (on_, EventHandle(..))
+import Effect.Aff (Aff, launchAff_, try, delay, forkAff, joinFiber, killFiber, Fiber)
+import Effect.Aff.AVar (AVar)
+import Effect.Aff.AVar as Avar
import Effect.Class (liftEffect)
+import Effect.Exception as Exception
import Log as Log
+import Node.EventEmitter (on_)
+import Metadata (enrichMetadata)
import Metrics as Metrics
+import Node.Encoding (Encoding(UTF8))
+import Node.FS.Aff as FSA
import Node.HTTP (createServer)
-import Node.HTTPS as HTTPS
-import Node.HTTP.Server as Server
-import Effect.Uncurried (mkEffectFn1)
-import Node.HTTP.ClientRequest as Client
import Node.HTTP.IncomingMessage as IM
-import Node.HTTP.Types (ServerResponse, IncomingMessage, IMServer)
-import Node.HTTP.ServerResponse (setStatusCode, toOutgoingMessage)
import Node.HTTP.OutgoingMessage (setHeader, toWriteable)
-import Node.Stream (end, write, writeString)
-import Node.Stream.Aff (readableToStringUtf8)
-import Node.Encoding (Encoding(UTF8))
+import Node.HTTP.ServerResponse (setStatusCode, toOutgoingMessage)
+import Node.HTTP.Server as Server
+import Node.HTTP.Types (ServerResponse, IncomingMessage, IMServer)
import Node.Net.Server (listenTcp, listeningH)
-import Node.Buffer (fromArrayBuffer)
-import Data.Either (Either(..), hush)
-import Control.Monad.Error.Class (throwError)
-import Effect.Exception as Exception
-import Effect.Aff (Aff, launchAff_, makeAff, nonCanceler, try, delay, forkAff, joinFiber, killFiber, Fiber)
-import Effect.Aff.AVar (AVar)
-import Effect.Aff.AVar as Avar
-import Unsafe.Coerce (unsafeCoerce)
-import Node.FS.Aff as FSA
-import Fetch (fetch, Method(GET), lookup)
-import Fetch.Argonaut.Json (fromJson)
-import Data.Maybe (Maybe(..), fromMaybe, isJust)
-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, null, mapMaybe, find)
-import Data.Tuple (Tuple(..))
-import Data.Foldable (for_, foldM, traverse_)
-import Data.Traversable (traverse)
-import Db (Connection, FilterField(..), connect, initDb, upsertScrobble, getScrobbles, checkExists, getOldestTs, initReleaseMetadata, getUnenrichedMbids, getEmptyGenreMbids, getArtistReleasesByMbids, upsertReleaseMetadata, touchGenreCheckedAt, getStats, ping, backupDb, withTransaction)
-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(..), stripPrefix)
import Node.Process (lookupEnv)
-import Data.String.Common (split) as String
-import Data.String.Regex (replace, parseFlags)
-import Data.String.Regex.Unsafe (unsafeRegex)
-import S3 (existsInS3, uploadToS3, getS3Url)
-import Effect.Aff.Retry (RetryStatus(..), exponentialBackoff, limitRetries, recovering)
+import Node.Stream (end, write, writeString)
+import Data.Argonaut (encodeJson, stringify)
+import Data.Argonaut.Core (toObject, toArray, toString, Json)
+import Foreign.Object as Object
+import Sync (lbSync, lbSyncLoop, lfSync, lfSyncLoop)
+import Types (Listen(..), ListenBrainzResponse(..), Payload(..), TrackMetadata(..))
+import Unsafe.Coerce (unsafeCoerce)
import Web.URL (URL)
import Web.URL as URL
import Web.URL.URLSearchParams as URLSearchParams
@@ -73,258 +64,6 @@ type UserContext =
, backupFiber :: Maybe (Fiber Unit)
}
-listenBrainzUrl :: String -> String
-listenBrainzUrl username = "https://api.listenbrainz.org/1/user/" <> username <> "/listens"
-
-fetchListenBrainzUrl :: String -> Aff String
-fetchListenBrainzUrl url = withRetry "ListenBrainz fetch" $ makeAff \callback -> do
- req <- HTTPS.get url
-
- req # on_ Client.responseH \res -> do
- launchAff_ do
- result <- try $ readableToStringUtf8 (IM.toReadable res)
- liftEffect $ case result of
- Left err ->
- callback (Left err)
- Right body ->
- if IM.statusCode res == 200 then
- callback (Right body)
- else
- callback (Left $ Exception.error $ "ListenBrainz API returned status " <> show (IM.statusCode res))
-
- let errorH = EventHandle "error" mkEffectFn1
- on_ errorH (\err -> callback (Left err)) (unsafeCoerce req)
-
- pure nonCanceler
-
-withRetry :: forall a. String -> Aff a -> Aff a
-withRetry label action = recovering policy [ \_ _ -> pure true ] \(RetryStatus status) -> do
- when (status.iterNumber > 0)
- $ Log.warn
- $ label <> " failed, retry attempt " <> show status.iterNumber
- action
- where
- policy = exponentialBackoff (Milliseconds 1000.0) <> limitRetries 5
-
-fetchLastfmPage :: String -> String -> Int -> Maybe Int -> Aff { tracks :: Array Json, totalPages :: Int }
-fetchLastfmPage apiKey lfmUser page mTo = withRetry "Last.fm fetch" do
- let
- toParam = case mTo of
- Just ts -> "&to=" <> show ts
- Nothing -> ""
- -- Build the base URL without the key so it is safe to log or include in errors.
- -- Last.fm does not support header-based auth, so the key must be a query param.
- baseUrl = "https://ws.audioscrobbler.com/2.0/?method=user.getrecenttracks&user="
- <> (fromMaybe lfmUser $ encodeURIComponent lfmUser)
- <> "&format=json&limit=200&page="
- <> show page
- <> toParam
- url = baseUrl <> "&api_key=" <> apiKey
- fr <- fetch url { method: GET }
- if fr.status == 200 then do
- json <- fromJson fr.json
- let
- parsed = do
- obj <- toObject json
- rt <- Object.lookup "recenttracks" obj >>= toObject
- tracks <- Object.lookup "track" rt >>= toArray
- attr <- Object.lookup "@attr" rt >>= toObject
- totalPagesStr <- Object.lookup "totalPages" attr >>= toString
- totalPages <- fromString totalPagesStr
- pure { tracks, totalPages }
- case parsed of
- Just result -> pure result
- Nothing -> liftEffect $ Exception.error "Last.fm: Failed to parse JSON response" # Exception.throwException
- else do
- liftEffect $ Exception.error ("Last.fm API returned status " <> show fr.status) # Exception.throwException
-
-lastfmTrackToListen :: Json -> Maybe Listen
-lastfmTrackToListen json = do
- obj <- toObject json
- trackName <- Object.lookup "name" obj >>= toString
- artistObj <- Object.lookup "artist" obj >>= toObject
- artistName <- Object.lookup "#text" artistObj >>= toString
- albumObj <- Object.lookup "album" obj >>= toObject
- let releaseName = Object.lookup "#text" albumObj >>= toString
- let
- releaseMbid = do
- s <- Object.lookup "mbid" albumObj >>= toString
- if s == "" then Nothing else Just s
- -- nowplaying tracks have no date field — naturally filtered out here
- dateObj <- Object.lookup "date" obj >>= toObject
- utsStr <- Object.lookup "uts" dateObj >>= toString
- ts <- fromString utsStr
- pure $ Listen
- { listenedAt: Just ts
- , trackMetadata: TrackMetadata
- { trackName: Just trackName
- , artistName: Just artistName
- , releaseName: releaseName
- , genre: Nothing
- , label: Nothing
- , mbidMapping: Just $ MbidMapping
- { releaseMbid: releaseMbid
- , caaReleaseMbid: releaseMbid
- }
- }
- }
-
-recordSyncSuccess :: String -> String -> Int -> Aff Unit
-recordSyncSuccess slug source n = do
- liftEffect $ Metrics.incSyncRuns slug source "success"
- when (n > 0) $ liftEffect $ Metrics.incSyncScrobbles slug source n
- liftEffect $ Metrics.setSyncLastSuccess slug source
-
--- One complete paginated pass; used for both initial and recurring syncs.
-lbSyncOnce :: Connection -> String -> String -> AVar Unit -> Boolean -> Aff Unit
-lbSyncOnce conn username slug writeLock initialSyncEnabled = void performFullSync
- where
- performFullSync = do
- when initialSyncEnabled $ Log.info $ "Starting ListenBrainz sync for " <> username
- result <- try $ fetchListenBrainzUrl (listenBrainzUrl username <> "?count=100")
- case result of
- Right body -> do
- case parseJson body >>= decodeJson of
- Left err -> do
- Log.error $ "Sync parse error: " <> show err
- liftEffect $ Metrics.incSyncRuns slug "listenbrainz" "error"
- Right (ListenBrainzResponse { payload: Payload { listens } }) -> do
- Tuple added (Tuple minTs hitCount) <- withTransaction conn writeLock (processListens listens)
- when (added > 0 || initialSyncEnabled)
- $ Log.info
- $ "ListenBrainz batch: added " <> show added <> ", " <> show hitCount <> " already present."
- let allExist = hitCount == length listens && not (null listens)
- if allExist || null listens then do
- when (added > 0) $ Log.info $ "ListenBrainz sync complete. Added " <> show added <> " new scrobbles."
- recordSuccess added
- else if initialSyncEnabled then do
- total <- paginateUntilDone 2 minTs added
- Log.info $ "ListenBrainz sync complete. Added " <> show total <> " new scrobbles."
- recordSuccess total
- else do
- when (added > 0) $ Log.info $ "ListenBrainz sync complete. Added " <> show added <> " new scrobbles."
- recordSuccess added
- Left err -> do
- Log.error $ "Sync fetch error: " <> Exception.message err
- liftEffect $ Metrics.incSyncRuns slug "listenbrainz" "error"
-
- paginateUntilDone batchNum minTs acc = case minTs of
- Nothing ->
- pure acc
- Just ts -> do
- Log.info $ "Fetching ListenBrainz batch " <> show batchNum <> " (before " <> show ts <> ")..."
- result <- try $ fetchListenBrainzUrl (listenBrainzUrl username <> "?count=100&max_ts=" <> show ts)
- case result of
- Right body -> do
- case parseJson body >>= decodeJson of
- Left err -> do
- Log.error $ "Sync parse error: " <> show err
- pure acc
- Right (ListenBrainzResponse { payload: Payload { listens } }) -> do
- Tuple added (Tuple newMinTs hitCount) <- withTransaction conn writeLock (processListens listens)
- Log.info $ "ListenBrainz batch " <> show batchNum <> ": added " <> show added <> ", " <> show hitCount <> " already present."
- let allExist = hitCount == length listens && not (null listens)
- if allExist || null listens then do
- pure (acc + added)
- else do
- paginateUntilDone (batchNum + 1) newMinTs (acc + added)
- Left err -> do
- Log.error $ "Sync fetch error: " <> Exception.message err
- pure acc
-
- recordSuccess = recordSyncSuccess slug "listenbrainz"
-
- processListens listens = do
- s <- foldM step { added: 0, minTs: Nothing, hitCount: 0 } listens
- pure $ Tuple s.added (Tuple s.minTs s.hitCount)
- where
- step s l@(Listen { listenedAt: Just ts }) = do
- exists <- checkExists conn ts
- if exists then pure s { minTs = Just ts, hitCount = s.hitCount + 1 }
- else do
- upsertScrobble conn l
- pure s { added = s.added + 1, minTs = Just ts }
- step s _ = do
- Log.warn "Skipping scrobble without timestamp"
- pure s
-
-lbSyncLoop :: Connection -> String -> String -> AVar Unit -> Boolean -> Aff Unit
-lbSyncLoop conn username slug writeLock initialSyncEnabled = forever do
- delay (Milliseconds 60000.0)
- lbSyncOnce conn username slug writeLock initialSyncEnabled
-
-lfSyncOnce :: Connection -> String -> String -> String -> AVar Unit -> Boolean -> Aff Unit
-lfSyncOnce conn apiKey lfmUser slug writeLock initialSyncEnabled = do
- void $ performLastfmSync
- when initialSyncEnabled $ void $ performLastfmBackfill
- where
- performLastfmSync = do
- when initialSyncEnabled $ Log.info $ "Starting Last.fm sync for " <> lfmUser
- { tracks, totalPages } <- fetchLastfmPage apiKey lfmUser 1 Nothing
- Tuple added hitCount <- withTransaction conn writeLock (processLastfmTracks tracks)
- when (added > 0 || initialSyncEnabled)
- $ Log.info
- $ "Last.fm page 1/" <> show totalPages <> ": added " <> show added <> ", " <> show hitCount <> " already present."
- let
- validTracks = mapMaybe lastfmTrackToListen tracks
- allExist = hitCount == length validTracks && not (null validTracks)
- if allExist || totalPages <= 1 then do
- when (added > 0) $ Log.info $ "Last.fm sync complete. Added " <> show added <> " new scrobbles."
- recordSuccess added
- else if initialSyncEnabled then do
- total <- paginateLastfmUntilDone 2 totalPages Nothing added
- Log.info $ "Last.fm sync complete. Added " <> show total <> " new scrobbles."
- recordSuccess total
- else do
- when (added > 0) $ Log.info $ "Last.fm sync complete. Added " <> show added <> " new scrobbles."
- recordSuccess added
-
- paginateLastfmUntilDone page totalPages mTo acc
- | page > totalPages = pure acc
- | otherwise = do
- when initialSyncEnabled $ Log.info $ "Fetching Last.fm page " <> show page <> "/" <> show totalPages <> "..."
- { tracks } <- fetchLastfmPage apiKey lfmUser page mTo
- Tuple added hitCount <- withTransaction conn writeLock (processLastfmTracks tracks)
- Log.info $ "Last.fm page " <> show page <> "/" <> show totalPages <> ": added " <> show added <> ", " <> show hitCount <> " already present."
- let
- validTracks = mapMaybe lastfmTrackToListen tracks
- allExist = hitCount == length validTracks && not (null validTracks)
- if allExist || null tracks then pure (acc + added)
- else paginateLastfmUntilDone (page + 1) totalPages mTo (acc + added)
-
- performLastfmBackfill = do
- mOldest <- getOldestTs conn
- for_ mOldest \oldestTs -> do
- when initialSyncEnabled $ Log.info $ "Checking for Last.fm history before " <> show oldestTs <> "..."
- { tracks, totalPages } <- fetchLastfmPage apiKey lfmUser 1 (Just (oldestTs - 1))
- if null tracks then
- when initialSyncEnabled $ Log.info "No older Last.fm history found."
- else do
- Log.info $ "Backfilling " <> show totalPages <> " pages of Last.fm history before " <> show oldestTs
- Tuple added hitCount <- withTransaction conn writeLock (processLastfmTracks tracks)
- Log.info $ "Last.fm backfill page 1/" <> show totalPages <> ": added " <> show added <> ", " <> show hitCount <> " already present."
- total <- paginateLastfmUntilDone 2 totalPages (Just (oldestTs - 1)) added
- Log.info $ "Last.fm backfill complete. Added " <> show total <> " older scrobbles."
-
- recordSuccess = recordSyncSuccess slug "lastfm"
-
- processLastfmTracks tracks = do
- s <- foldM step { added: 0, hitCount: 0 } (mapMaybe lastfmTrackToListen tracks)
- pure $ Tuple s.added s.hitCount
- where
- step s l@(Listen { listenedAt: Just ts }) = do
- exists <- checkExists conn ts
- if exists then pure s { hitCount = s.hitCount + 1 }
- else do
- upsertScrobble conn l
- pure s { added = s.added + 1 }
- step s _ = pure s
-
-lfSyncLoop :: Connection -> String -> String -> String -> AVar Unit -> Boolean -> Aff Unit
-lfSyncLoop conn apiKey lfmUser slug writeLock initialSyncEnabled = forever do
- delay (Milliseconds 60000.0)
- lfSyncOnce conn apiKey lfmUser slug writeLock initialSyncEnabled
-
normalizePath :: String -> String
normalizePath path = case stripPrefix (Pattern "/u/") path of
Just _ -> "/u/:slug"
@@ -371,9 +110,9 @@ routeRequest metricsEnabled contexts url path allUsers res = liftEffect $ case p
"/stats" ->
withUser url \ctx -> serveStats ctx.conn url res
"/cover" ->
- withUser url \ctx -> serveCover ctx.config ctx.slug url res
+ withUser url \ctx -> launchAff_ $ serveCover serveNotFound ctx.config ctx.slug url res
"/similar" ->
- withUser url \ctx -> serveSimilar ctx.slug ctx.config url res
+ withUser url \ctx -> serveSimilar serveBadRequest serveError ctx.slug ctx.config url res
"/healthz" ->
withUser url \ctx -> serveHealthz ctx.conn res
_ ->
@@ -442,165 +181,6 @@ parseFilterField "genre" = Just FilterGenre
parseFilterField "track" = Just FilterTrack
parseFilterField _ = Nothing
-sanitizeKey :: String -> String
-sanitizeKey = replace re1 "_" >>> replace re2 "_"
- where
- re1 = unsafeRegex "[^a-z0-9.-]" (parseFlags "gi")
- re2 = unsafeRegex "_{2,}" (parseFlags "g")
-
--- Fetch the Last.fm image URL for an artist/release (no caching, no serving).
-fetchLastfmCoverUrl :: UserConfig -> String -> String -> Aff (Maybe String)
-fetchLastfmCoverUrl cfg artist release = case cfg.lastfmApiKey of
- Nothing ->
- pure Nothing
- Just k -> do
- let
- searchUrl = "https://ws.audioscrobbler.com/2.0/?method=album.getinfo&artist="
- <> (fromMaybe "" $ encodeURIComponent artist)
- <> "&album="
- <> (fromMaybe "" $ encodeURIComponent release)
- <> "&format=json&api_key="
- <> k
- Log.info $ "Searching Last.fm for: " <> artist <> " - " <> release
- result <- try $ fetch searchUrl { method: GET }
- case result of
- Right fr | fr.status == 200 -> do
- json <- fromJson fr.json
- pure $ do
- obj <- toObject json
- album <- Object.lookup "album" obj >>= toObject
- images <- Object.lookup "image" album >>= toArray
- imgObj <- images !! 2 >>= toObject
- u <- Object.lookup "#text" imgObj >>= toString
- if u == "" then Nothing else Just u
- _ ->
- pure Nothing
-
--- Fetch the Discogs image URL for an artist/release (no caching, no serving).
-fetchDiscogsCoverUrl :: UserConfig -> String -> String -> Aff (Maybe String)
-fetchDiscogsCoverUrl cfg artist release = case cfg.discogsToken of
- Nothing ->
- pure Nothing
- Just t -> do
- let
- queryStr = artist <> " " <> release
- searchUrl = "https://api.discogs.com/database/search?q="
- <> (fromMaybe "" $ encodeURIComponent queryStr)
- <> "&type=release&per_page=1"
- Log.info $ "Searching Discogs for: " <> queryStr
- result <- try $ fetch searchUrl { method: GET, headers: { "User-Agent": "corpus/1.0 +https://github.com/mtmn/corpus", "Authorization": "Discogs token=" <> t } }
- case result of
- Right fr | fr.status == 200 -> do
- json <- fromJson fr.json
- pure $ do
- obj <- toObject json
- results <- Object.lookup "results" obj >>= toArray
- firstResult <- results !! 0 >>= toObject
- Object.lookup "cover_image" firstResult >>= toString
- _ ->
- pure Nothing
-
-type CoverSource =
- { name :: String
- , s3Key :: String
- , findUrl :: Aff (Maybe String)
- }
-
-coverSources :: String -> String -> String -> UserConfig -> Array CoverSource
-coverSources mbid artist release cfg =
- let
- safeArtist = sanitizeKey artist
- safeRelease = sanitizeKey release
- in
- [ { name: "caa"
- , s3Key: "covers/caa/" <> sanitizeKey mbid <> ".jpg"
- , findUrl:
- if mbid == "" then pure Nothing
- else pure $ Just $ "https://coverartarchive.org/release/" <> mbid <> "/front-250"
- }
- , { name: "lastfm"
- , s3Key: "covers/lastfm/" <> safeArtist <> "-" <> safeRelease <> ".jpg"
- , findUrl:
- if artist == "" || release == "" then pure Nothing
- else fetchLastfmCoverUrl cfg artist release
- }
- , { name: "discogs"
- , s3Key: "covers/discogs/" <> safeArtist <> "-" <> safeRelease <> ".jpg"
- , findUrl:
- if artist == "" || release == "" then pure Nothing
- else fetchDiscogsCoverUrl cfg artist release
- }
- ]
-
-serveCover :: UserConfig -> String -> URL -> Response -> Effect Unit
-serveCover cfg slug url res = launchAff_ do
- let
- mbid = fromMaybe "" (getQueryParam "mbid" url)
- artist = fromMaybe "" (getQueryParam "artist" url)
- release = fromMaybe "" (getQueryParam "release" url)
- s3cfg = s3ConfigFromUser cfg
-
- served <- foldM (trySource s3cfg) false (coverSources mbid artist release cfg)
- unless served $ liftEffect $ serveNotFound res
-
- where
- trySource _ true _ = pure true
- trySource s3cfg false { name, s3Key, findUrl } = do
- cached <- checkS3 s3cfg s3Key
- if cached then do
- Log.info $ "Serving " <> name <> " cover from S3: " <> s3Key
- liftEffect $ Metrics.incCoverRequest slug name "s3_hit"
- serveS3 s3cfg s3Key res
- pure true
- else do
- mUrl <- findUrl
- case mUrl of
- Nothing ->
- pure false
- Just urlStr -> do
- success <- tryProxyAndCache s3cfg urlStr s3Key res
- liftEffect $
- if success then Metrics.incCoverRequest slug name "fetch"
- else Metrics.incCoverRequest slug name "miss"
- pure success
-
- checkS3 s3cfg s3Key
- | not cfg.coverCacheEnabled = pure false
- | otherwise = do
- result <- try $ existsInS3 s3cfg s3Key
- pure $ case result of
- Right b -> b
- Left _ -> false
-
- serveS3 s3cfg s3Key response = liftEffect $ do
- setStatusCode 302 response
- setHeader "Location" (getS3Url s3cfg s3Key) (toOutgoingMessage response)
- end (toWriteable (toOutgoingMessage response))
-
- tryProxyAndCache s3cfg urlStr s3Key response = do
- fetchResult <- try $ fetch urlStr { method: GET }
- case fetchResult of
- Right fr | fr.status == 200 -> do
- Log.info $ "Proxying and caching image: " <> urlStr
- let contentType = fromMaybe "image/jpeg" $ lookup "content-type" fr.headers
- buf <- fr.arrayBuffer
- liftEffect $ do
- setStatusCode fr.status response
- setHeader "Content-Type" contentType (toOutgoingMessage response)
- setHeader "Cache-Control" "public, max-age=86400" (toOutgoingMessage response)
- let writer = toWriteable (toOutgoingMessage response)
- nativeBuf <- fromArrayBuffer buf
- void $ write writer nativeBuf
- end writer
- 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
-
serveProxy :: Connection -> URL -> Response -> Effect Unit
serveProxy db url res = do
setHeader "Content-Type" "application/json" (toOutgoingMessage res)
@@ -624,6 +204,23 @@ serveProxy db url res = do
void $ writeString w UTF8 responseBody
end w
+serveStats :: Connection -> URL -> Response -> Effect Unit
+serveStats db url res = do
+ setHeader "Content-Type" "application/json" (toOutgoingMessage res)
+ launchAff_ do
+ let period = getQueryParam "period" url
+ let section = getQueryParam "section" url
+ let safeDate = map (replace (unsafeRegex "[^0-9\\-]" (parseFlags "g")) "")
+ let mFrom = safeDate (getQueryParam "from" url)
+ let mTo = safeDate (getQueryParam "to" url)
+ stats <- getStats db period mFrom mTo section
+ let responseBody = stringify $ encodeJson stats
+ liftEffect $ do
+ setStatusCode 200 res
+ let w = toWriteable (toOutgoingMessage res)
+ void $ writeString w UTF8 responseBody
+ end w
+
serveAsset :: String -> String -> Response -> Effect Unit
serveAsset contentType path res = do
setHeader "Content-Type" contentType (toOutgoingMessage res)
@@ -687,289 +284,6 @@ serveError res statusCode statusName message = do
void $ writeString w UTF8 (statusName <> ": " <> message)
end w
-fetchCosineSimilar :: String -> UserConfig -> String -> Aff String
-fetchCosineSimilar slug cfg query = do
- let apiKey = fromMaybe "" cfg.cosineApiKey
- if apiKey == "" then do
- Log.warn "cosineApiKey not configured for similar tracks"
- liftEffect $ Metrics.incCosineRequest slug "not_configured"
- pure "{\"data\":{\"similar_tracks\":[]},\"success\":true}"
- else do
- let headers = { "User-Agent": "corpus/1.0 +https://github.com/mtmn/corpus", "Authorization": "Bearer " <> apiKey }
- let searchUrl = "https://cosine.club/api/v1/search?q=" <> (fromMaybe "" $ encodeURIComponent query) <> "&limit=1"
- Log.info $ "Cosine Club: searching for: " <> query
- searchResult <- try $ fetch searchUrl { method: GET, headers: headers }
- case searchResult of
- Left err -> do
- liftEffect $ Metrics.incCosineRequest slug "error"
- throwError err
- Right searchRes ->
- if searchRes.status == 429 then do
- Log.warn "Cosine Club: rate limited on search"
- liftEffect $ Metrics.incCosineRequest slug "rate_limited"
- throwError (Exception.error "Rate limit exceeded")
- else if searchRes.status /= 200 then do
- Log.warn $ "Cosine Club: search returned " <> show searchRes.status
- liftEffect $ Metrics.incCosineRequest slug "error"
- throwError (Exception.error "Search API error")
- else do
- searchBody <- searchRes.text
- let
- mTrackId = do
- json <- hush $ parseJson searchBody
- obj <- toObject json
- arr <- Object.lookup "data" obj >>= toArray
- first <- arr !! 0
- firstObj <- toObject first
- Object.lookup "id" firstObj >>= toString
- case mTrackId of
- Nothing -> do
- Log.info $ "Cosine Club: track not indexed: " <> query
- liftEffect $ Metrics.incCosineRequest slug "not_indexed"
- pure "{\"data\":{\"similar_tracks\":[]},\"success\":true}"
- Just trackId -> do
- let similarUrl = "https://cosine.club/api/v1/tracks/" <> trackId <> "/similar?limit=10"
- Log.info $ "Cosine Club: fetching similar for ID " <> trackId
- similarResult <- try $ fetch similarUrl { method: GET, headers: headers }
- case similarResult of
- Left err -> do
- liftEffect $ Metrics.incCosineRequest slug "error"
- throwError err
- Right similarRes ->
- if similarRes.status == 429 then do
- Log.warn "Cosine Club: rate limited on similar"
- liftEffect $ Metrics.incCosineRequest slug "rate_limited"
- throwError (Exception.error "Rate limit exceeded")
- else if similarRes.status /= 200 then do
- Log.warn $ "Cosine Club: similar API returned " <> show similarRes.status
- liftEffect $ Metrics.incCosineRequest slug "error"
- throwError (Exception.error "Similar API error")
- else do
- liftEffect $ Metrics.incCosineRequest slug "success"
- similarRes.text
-
-serveStats :: Connection -> URL -> Response -> Effect Unit
-serveStats db url res = do
- setHeader "Content-Type" "application/json" (toOutgoingMessage res)
- launchAff_ do
- let period = getQueryParam "period" url
- let section = getQueryParam "section" url
- let safeDate = map (replace (unsafeRegex "[^0-9\\-]" (parseFlags "g")) "")
- let mFrom = safeDate (getQueryParam "from" url)
- let mTo = safeDate (getQueryParam "to" url)
- stats <- getStats db period mFrom mTo section
- let responseBody = stringify $ encodeJson stats
- liftEffect $ do
- setStatusCode 200 res
- let w = toWriteable (toOutgoingMessage res)
- void $ writeString w UTF8 responseBody
- end w
-
-serveSimilar :: String -> UserConfig -> URL -> Response -> Effect Unit
-serveSimilar slug cfg url res = do
- setHeader "Content-Type" "application/json" (toOutgoingMessage res)
- launchAff_ do
- let artist = fromMaybe "" (getQueryParam "artist" url)
- let track = fromMaybe "" (getQueryParam "track" url)
- if artist == "" || track == "" then
- liftEffect $ serveBadRequest res "Artist and track parameters are required"
- else do
- let query = artist <> " - " <> track
- result <- try $ fetchCosineSimilar slug cfg query
-
- case result of
- Left err -> do
- Log.error $ "Cosine Club API error: " <> Exception.message err
- liftEffect $ serveError res 502 "Bad Gateway" "Failed to fetch similar tracks"
- Right responseBody -> do
- liftEffect $ do
- setStatusCode 200 res
- let w = toWriteable (toOutgoingMessage res)
- void $ writeString w UTF8 responseBody
- end w
-
-type MbData = { genre :: Maybe String, label :: Maybe String, year :: Maybe Int }
-
-fetchMusicBrainzRelease :: String -> Aff (Maybe MbData)
-fetchMusicBrainzRelease mbid = do
- let url = "https://musicbrainz.org/ws/2/release/" <> mbid <> "?inc=genres+labels+release-groups&fmt=json"
- result <- try $ fetch url { method: GET, headers: { "User-Agent": "corpus/1.0 +https://github.com/mtmn/corpus" } }
- case result of
- Left err -> do
- Log.error $ "MusicBrainz fetch error for " <> mbid <> ": " <> Exception.message err
- pure Nothing
- Right fr | fr.status == 200 -> do
- jsonResult <- try $ fromJson fr.json
- case jsonResult of
- Left err -> do
- Log.error $ "MusicBrainz JSON parse error for " <> mbid <> ": " <> Exception.message err
- pure $ Just { genre: Nothing, label: Nothing, year: Nothing }
- Right json -> do
- let
- genre = do
- obj <- toObject json
- genres <- Object.lookup "genres" obj >>= toArray
- firstGenre <- genres !! 0 >>= toObject
- Object.lookup "name" firstGenre >>= toString
- label = do
- obj <- toObject json
- labelInfo <- Object.lookup "label-info" obj >>= toArray
- firstLabel <- labelInfo !! 0 >>= toObject
- labelObj <- Object.lookup "label" firstLabel >>= toObject
- Object.lookup "name" labelObj >>= toString
- year = do
- obj <- toObject json
- rg <- Object.lookup "release-group" obj >>= toObject
- dateStr <- Object.lookup "first-release-date" rg >>= toString
- String.split (Pattern "-") dateStr !! 0 >>= fromString
- Log.info $ "Enriched " <> mbid <> ": genre=" <> show genre <> " label=" <> show label <> " year=" <> show year
-
- when (genre == Nothing && label == Nothing && year == Nothing)
- $ Log.warn
- $ "All fields empty for " <> mbid <> " - possible parsing issue or missing data"
-
- pure $ Just { genre, label, year }
- Right fr | fr.status == 404 -> do
- Log.info $ "MusicBrainz 404 for " <> mbid
- pure $ Just { genre: Nothing, label: Nothing, year: Nothing }
- Right fr -> do
- Log.warn $ "MusicBrainz " <> show fr.status <> " for " <> mbid <> ", will retry"
- pure Nothing
-
--- 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&artist=" <> (fromMaybe "" $ encodeURIComponent artist) <> "&album=" <> (fromMaybe "" $ encodeURIComponent release) <> "&format=json" <> "&api_key=" <> k
- 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"
- pure Nothing
-
--- 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"
- Log.info $ "Fetching Discogs genre for: " <> queryStr
- result <- try $ fetch searchUrl { method: GET, headers: { "User-Agent": "corpus/1.0 +https://github.com/mtmn/corpus", "Authorization": "Discogs token=" <> t } }
- case result of
- Right 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
-
-type GenreSource =
- { name :: String
- , enabled :: Boolean
- , fetch :: Aff (Maybe String)
- }
-
--- Try each source in order, stopping at the first that returns Just.
--- Records found/not_found metrics only for sources that are enabled and queried.
-fetchFallbackGenre :: String -> Array GenreSource -> Aff (Maybe String)
-fetchFallbackGenre slug = foldM trySource Nothing
- where
- trySource (Just g) _ = pure (Just g)
- trySource Nothing { name, enabled, fetch }
- | not enabled = pure Nothing
- | otherwise = do
- result <- fetch
- liftEffect $ case result of
- Just _ -> Metrics.incEnrichmentFetch slug name "found"
- Nothing -> Metrics.incEnrichmentFetch slug name "not_found"
- pure result
-
-enrichMetadata :: Connection -> UserConfig -> String -> Aff Unit
-enrichMetadata conn cfg slug = forever do
- unenrichedMbids <- getUnenrichedMbids conn 10
- emptyGenreMbids <- getEmptyGenreMbids conn 10
- let allMbids = unenrichedMbids <> emptyGenreMbids
-
- liftEffect $ Metrics.setEnrichmentQueueSize slug "unenriched" (length unenrichedMbids)
- liftEffect $ Metrics.setEnrichmentQueueSize slug "empty_genre" (length emptyGenreMbids)
-
- if null allMbids then
- delay (Milliseconds 60000.0)
- else do
- Log.info $ "Processing " <> show (length unenrichedMbids) <> " unenriched + " <> show (length emptyGenreMbids) <> " empty genre releases"
- artistReleaseMap <- getArtistReleasesByMbids conn allMbids
- for_ allMbids \mbid -> do
- delay (Milliseconds 1100.0)
- result <- try $ fetchMusicBrainzRelease mbid
- case result of
- Left err -> do
- Log.error $ "Enrichment error: " <> Exception.message err
- liftEffect $ Metrics.incEnrichmentFetch slug "musicbrainz" "error"
- Right Nothing -> do
- liftEffect $ Metrics.incEnrichmentFetch slug "musicbrainz" "retry"
- upsertReleaseMetadata conn mbid Nothing Nothing Nothing
- touchGenreCheckedAt conn mbid
- Right (Just mbdata) -> do
- liftEffect $ Metrics.incEnrichmentFetch slug "musicbrainz" "success"
- case mbdata.genre of
- Just _ ->
- upsertReleaseMetadata conn mbid mbdata.genre mbdata.label mbdata.year
- Nothing -> do
- let artistRelease = Object.lookup mbid artistReleaseMap
- case artistRelease of
- Just { artist, release } -> do
- let
- sources =
- [ { name: "lastfm", enabled: isJust cfg.lastfmApiKey, fetch: fetchLastfmGenre cfg.lastfmApiKey artist release }
- , { name: "discogs", enabled: isJust cfg.discogsToken, fetch: fetchDiscogsGenre cfg.discogsToken artist release }
- ]
- finalGenre <- fetchFallbackGenre slug sources
- upsertReleaseMetadata conn mbid finalGenre mbdata.label mbdata.year
- case finalGenre of
- Just genre ->
- Log.info $ "Added fallback genre for " <> mbid <> ": " <> genre
- Nothing -> do
- Log.info $ "No genre found in any source for " <> mbid
- touchGenreCheckedAt conn mbid
- Nothing -> do
- Log.warn $ "No artist/release info found for MBID " <> mbid <> ", cannot use fallback sources"
- upsertReleaseMetadata conn mbid mbdata.genre mbdata.label mbdata.year
- touchGenreCheckedAt conn mbid
-
--- Initialise one user: connect DB, start sync loops, return a UserContext.
startUser :: UserEntry -> Aff UserContext
startUser { slug, name, config } = do
Log.info $ "Starting user: " <> if slug == "" then "(root)" else slug
@@ -986,10 +300,10 @@ startUser { slug, name, config } = do
-- start immediately. A separate fiber waits for them to finish before
-- starting the recurring loops (preserving the original ordering guarantee).
lbFiber <- case config.listenbrainzUser of
- Just username -> Just <$> forkAff (lbSyncOnce conn username slug writeLock config.initialSync)
+ 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 (lfSyncOnce conn apiKey lfmUser slug writeLock config.initialSync)
+ Just lfmUser, Just apiKey -> Just <$> forkAff (lfSync conn apiKey lfmUser slug writeLock)
_, _ -> pure Nothing
-- Wait for initial syncs then start recurring loops — all in background.
@@ -997,9 +311,9 @@ startUser { slug, name, config } = do
for_ lbFiber joinFiber
for_ lfFiber joinFiber
for_ config.listenbrainzUser \username ->
- void $ forkAff $ lbSyncLoop conn username slug writeLock config.initialSync
+ void $ forkAff $ lbSyncLoop conn username slug writeLock
case config.lastfmUser, config.lastfmApiKey of
- Just lfmUser, Just apiKey -> void $ forkAff $ lfSyncLoop conn apiKey lfmUser slug writeLock config.initialSync
+ Just lfmUser, Just apiKey -> void $ forkAff $ lfSyncLoop conn apiKey lfmUser slug writeLock
_, _ -> pure unit
-- Background tasks that don't depend on initial sync completion.
@@ -1013,23 +327,13 @@ startUser { slug, name, config } = do
cleanupUser :: UserContext -> Aff Unit
cleanupUser ctx = do
- Log.info $ "Cleaning up user: " <> if ctx.slug == "" then "(root)" else ctx.slug
- -- Kill background fibers
- case ctx.enrichMetadataFiber of
- Just fiber -> do
- Log.info "Killing enrich metadata fiber"
- void $ try $ killFiber (Exception.error "Server shutting down") fiber
- Nothing -> do
- pure unit
- case ctx.backupFiber of
- Just fiber -> do
- Log.info "Killing backup fiber"
- void $ try $ killFiber (Exception.error "Server shutting down") fiber
- Nothing -> do
- pure unit
- -- Close database connection
- Log.info "Closing database connection"
- void $ try $ ping ctx.conn
+ let label = if ctx.slug == "" then "(root)" else ctx.slug
+ Log.info $ "Shutting down user: " <> label
+ for_ ctx.enrichMetadataFiber \fiber ->
+ void $ try $ killFiber (Exception.error "Server shutting down") fiber
+ for_ ctx.backupFiber \fiber ->
+ void $ try $ killFiber (Exception.error "Server shutting down") fiber
+ Log.info $ "Closed user: " <> label
foreign import dotenvConfig :: Effect Unit
@@ -1044,7 +348,7 @@ main = 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"
+ Log.info $ "Loaded " <> show (length appConfig.users) <> " user(s) from " <> configFile
contexts <- traverse startUser appConfig.users
liftEffect $ do
server <- createServer
@@ -1056,8 +360,3 @@ main = do
listenTcp netServer { host: "127.0.0.1", port: appConfig.port, backlog: 128 }
-cleanupAll :: Array UserContext -> Aff Unit
-cleanupAll contexts = do
- Log.info "Starting graceful shutdown of all users"
- traverse_ cleanupUser contexts
- Log.info "Graceful shutdown complete"
diff --git a/src/Metadata.purs b/src/Metadata.purs
@@ -0,0 +1,208 @@
+module Metadata
+ ( MbData
+ , GenreSource
+ , fetchMusicBrainzRelease
+ , fetchLastfmGenre
+ , fetchDiscogsGenre
+ , fetchFallbackGenre
+ , enrichMetadata
+ ) where
+
+import Prelude
+
+import Config (UserConfig)
+import Control.Monad.Rec.Class (forever)
+import Data.Array ((!!), length, null)
+import Data.Either (Either(..))
+import Data.Foldable (foldM, for_)
+import Data.Int (fromString)
+import Data.Maybe (Maybe(..), fromMaybe, isJust)
+import Data.String (Pattern(..))
+import Data.String.Common as String
+import Data.Time.Duration (Milliseconds(..))
+import Data.Argonaut.Core (toArray, toObject, toString)
+import Db (Connection, getArtistReleasesByMbids, getEmptyGenreMbids, getUnenrichedMbids, touchGenreCheckedAt, upsertReleaseMetadata)
+import Effect.Aff (Aff, delay, try)
+import Effect.Class (liftEffect)
+import Effect.Exception as Exception
+import Fetch (fetch, Method(GET))
+import Fetch.Argonaut.Json (fromJson)
+import Foreign.Object as Object
+import JSURI (encodeURIComponent)
+import Log as Log
+import Metrics as Metrics
+
+type MbData = { genre :: Maybe String, label :: Maybe String, year :: Maybe Int }
+
+type GenreSource =
+ { name :: String
+ , enabled :: Boolean
+ , fetch :: Aff (Maybe String)
+ }
+
+fetchMusicBrainzRelease :: String -> Aff (Maybe MbData)
+fetchMusicBrainzRelease mbid = do
+ let url = "https://musicbrainz.org/ws/2/release/" <> mbid <> "?inc=genres+labels+release-groups&fmt=json"
+ result <- try $ fetch url { method: GET, headers: { "User-Agent": "corpus/1.0 +https://github.com/mtmn/corpus" } }
+ case result of
+ Left err -> do
+ Log.error $ "MusicBrainz fetch error for " <> mbid <> ": " <> Exception.message err
+ pure Nothing
+ Right fr | fr.status == 200 -> do
+ jsonResult <- try $ fromJson fr.json
+ case jsonResult of
+ Left err -> do
+ Log.error $ "MusicBrainz JSON parse error for " <> mbid <> ": " <> Exception.message err
+ pure $ Just { genre: Nothing, label: Nothing, year: Nothing }
+ Right json -> do
+ let
+ genre = do
+ obj <- toObject json
+ genres <- Object.lookup "genres" obj >>= toArray
+ firstGenre <- genres !! 0 >>= toObject
+ Object.lookup "name" firstGenre >>= toString
+ label = do
+ obj <- toObject json
+ labelInfo <- Object.lookup "label-info" obj >>= toArray
+ firstLabel <- labelInfo !! 0 >>= toObject
+ labelObj <- Object.lookup "label" firstLabel >>= toObject
+ Object.lookup "name" labelObj >>= toString
+ year = do
+ obj <- toObject json
+ rg <- Object.lookup "release-group" obj >>= toObject
+ dateStr <- Object.lookup "first-release-date" rg >>= toString
+ String.split (Pattern "-") dateStr !! 0 >>= fromString
+ Log.info $ "Enriched " <> mbid <> ": genre=" <> show genre <> " label=" <> show label <> " year=" <> show year
+ when (genre == Nothing && label == Nothing && year == Nothing)
+ $ Log.warn
+ $ "All fields empty for " <> mbid <> " - possible parsing issue or missing data"
+ pure $ Just { genre, label, year }
+ Right fr | fr.status == 404 -> do
+ Log.info $ "MusicBrainz 404 for " <> mbid
+ pure $ Just { genre: Nothing, label: Nothing, year: Nothing }
+ Right fr -> do
+ Log.warn $ "MusicBrainz " <> show fr.status <> " for " <> mbid <> ", will retry"
+ pure Nothing
+
+fetchLastfmGenre :: Maybe String -> String -> String -> Aff (Maybe String)
+fetchLastfmGenre Nothing _ _ = do
+ Log.warn "lastfmApiKey not configured for genre fallback"
+ pure Nothing
+fetchLastfmGenre (Just k) artist release = do
+ let searchUrl = "https://ws.audioscrobbler.com/2.0/?method=album.getinfo&artist=" <> (fromMaybe "" $ encodeURIComponent artist) <> "&album=" <> (fromMaybe "" $ encodeURIComponent release) <> "&format=json" <> "&api_key=" <> k
+ 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"
+ pure Nothing
+
+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"
+ Log.info $ "Fetching Discogs genre for: " <> queryStr
+ result <- try $ fetch searchUrl { method: GET, headers: { "User-Agent": "corpus/1.0 +https://github.com/mtmn/corpus", "Authorization": "Discogs token=" <> t } }
+ case result of
+ Right 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
+
+fetchFallbackGenre :: String -> Array GenreSource -> Aff (Maybe String)
+fetchFallbackGenre slug = foldM trySource Nothing
+ where
+ trySource (Just g) _ = pure (Just g)
+ trySource Nothing { name, enabled, fetch }
+ | not enabled = pure Nothing
+ | otherwise = do
+ result <- fetch
+ liftEffect $ case result of
+ Just _ -> Metrics.incEnrichmentFetch slug name "found"
+ Nothing -> Metrics.incEnrichmentFetch slug name "not_found"
+ pure result
+
+enrichMetadata :: Connection -> UserConfig -> String -> Aff Unit
+enrichMetadata conn cfg slug = forever do
+ unenrichedMbids <- getUnenrichedMbids conn 10
+ emptyGenreMbids <- getEmptyGenreMbids conn 10
+ let allMbids = unenrichedMbids <> emptyGenreMbids
+
+ liftEffect $ Metrics.setEnrichmentQueueSize slug "unenriched" (length unenrichedMbids)
+ liftEffect $ Metrics.setEnrichmentQueueSize slug "empty_genre" (length emptyGenreMbids)
+
+ if null allMbids then
+ delay (Milliseconds 60000.0)
+ else do
+ Log.info $ "Processing " <> show (length unenrichedMbids) <> " unenriched + " <> show (length emptyGenreMbids) <> " empty genre releases"
+ artistReleaseMap <- getArtistReleasesByMbids conn allMbids
+ for_ allMbids \mbid -> do
+ delay (Milliseconds 1100.0)
+ result <- try $ fetchMusicBrainzRelease mbid
+ case result of
+ Left err -> do
+ Log.error $ "Enrichment error: " <> Exception.message err
+ liftEffect $ Metrics.incEnrichmentFetch slug "musicbrainz" "error"
+ Right Nothing -> do
+ liftEffect $ Metrics.incEnrichmentFetch slug "musicbrainz" "retry"
+ upsertReleaseMetadata conn mbid Nothing Nothing Nothing
+ touchGenreCheckedAt conn mbid
+ Right (Just mbdata) -> do
+ liftEffect $ Metrics.incEnrichmentFetch slug "musicbrainz" "success"
+ case mbdata.genre of
+ Just _ ->
+ upsertReleaseMetadata conn mbid mbdata.genre mbdata.label mbdata.year
+ Nothing -> do
+ let artistRelease = Object.lookup mbid artistReleaseMap
+ case artistRelease of
+ Just { artist, release } -> do
+ let
+ sources =
+ [ { name: "lastfm", enabled: isJust cfg.lastfmApiKey, fetch: fetchLastfmGenre cfg.lastfmApiKey artist release }
+ , { name: "discogs", enabled: isJust cfg.discogsToken, fetch: fetchDiscogsGenre cfg.discogsToken artist release }
+ ]
+ finalGenre <- fetchFallbackGenre slug sources
+ upsertReleaseMetadata conn mbid finalGenre mbdata.label mbdata.year
+ case finalGenre of
+ Just genre ->
+ Log.info $ "Added fallback genre for " <> mbid <> ": " <> genre
+ Nothing -> do
+ Log.info $ "No genre found in any source for " <> mbid
+ touchGenreCheckedAt conn mbid
+ Nothing -> do
+ Log.warn $ "No artist/release info found for MBID " <> mbid <> ", cannot use fallback sources"
+ upsertReleaseMetadata conn mbid mbdata.genre mbdata.label mbdata.year
+ touchGenreCheckedAt conn mbid
+\ No newline at end of file
diff --git a/src/State.elm b/src/State.elm
@@ -0,0 +1,502 @@
+module State exposing (init, subscriptions, update)
+
+import Api exposing (fetchListens, fetchSectionData, fetchSimilarTracks, fetchStats, httpErrorToString)
+import Browser
+import Browser.Navigation as Nav
+import Dict
+import Set
+import Task
+import Time
+import Types exposing (Flags, Model, Msg(..), Period(..), SimilarState(..), Stats, StatsEntry, Tab(..))
+import Url
+import Url.Parser exposing ((</>), (<?>))
+import Url.Parser.Query as Query
+
+
+init : Flags -> Url.Url -> Nav.Key -> ( Model, Cmd Msg )
+init flags url navKey =
+ let
+ page =
+ parsePageParam url
+
+ offset =
+ max 0 ((page - 1) * 25)
+ in
+ ( { navKey = navKey
+ , listens = []
+ , stats = Nothing
+ , error = Nothing
+ , loading = True
+ , currentTime = Nothing
+ , failedCovers = Set.empty
+ , hoveredCover = Nothing
+ , expandedSections = Set.empty
+ , loadedSections = Set.empty
+ , offset = offset
+ , limit = 25
+ , activeTab = ListensTab
+ , activeFilter = Nothing
+ , statsPeriod = AllTime
+ , customInput = ""
+ , showCustomInput = False
+ , customError = Nothing
+ , userSlug = flags.userSlug
+ , similarStates = Dict.empty
+ , allUsers = flags.allUsers
+ , searchInput = ""
+ , activeSearch = Nothing
+ }
+ , Cmd.batch
+ [ fetchListens flags.userSlug 25 offset Nothing Nothing
+ , Task.perform GotTime Time.now
+ ]
+ )
+
+
+parsePageParam : Url.Url -> Int
+parsePageParam url =
+ let
+ pageParser =
+ Url.Parser.oneOf
+ [ Url.Parser.top <?> Query.int "page"
+ , (Url.Parser.s "u" </> Url.Parser.string <?> Query.int "page") |> Url.Parser.map (\_ p -> p)
+ ]
+ in
+ Url.Parser.parse pageParser url
+ |> Maybe.andThen identity
+ |> Maybe.withDefault 1
+
+
+
+-- MSG
+
+
+update : Msg -> Model -> ( Model, Cmd Msg )
+update msg model =
+ case msg of
+ UrlRequested urlRequest ->
+ case urlRequest of
+ Browser.Internal url ->
+ ( model, Nav.pushUrl model.navKey (Url.toString url) )
+
+ Browser.External href ->
+ ( model, Nav.load href )
+
+ UrlChanged url ->
+ let
+ newUserSlug =
+ if String.startsWith "/u/" url.path then
+ String.dropLeft 3 url.path
+
+ else
+ ""
+
+ page =
+ parsePageParam url
+
+ targetOffset =
+ max 0 ((page - 1) * model.limit)
+
+ isNaked =
+ url.query == Nothing
+
+ userChanged =
+ newUserSlug /= model.userSlug
+
+ needsCleanStart =
+ userChanged || isNaked
+
+ finalFilter =
+ if needsCleanStart then
+ Nothing
+
+ else
+ model.activeFilter
+
+ finalSearch =
+ if needsCleanStart then
+ Nothing
+
+ else
+ model.activeSearch
+
+ finalOffset =
+ if needsCleanStart then
+ 0
+
+ else
+ targetOffset
+ in
+ if userChanged || model.offset /= finalOffset || model.activeFilter /= finalFilter || model.activeSearch /= finalSearch then
+ let
+ newModel =
+ { model
+ | userSlug = newUserSlug
+ , offset = finalOffset
+ , activeFilter = finalFilter
+ , activeSearch = finalSearch
+ , searchInput =
+ if needsCleanStart then
+ ""
+
+ else
+ model.searchInput
+ , activeTab = ListensTab
+ , loading = True
+ }
+
+ clearedModel =
+ if userChanged then
+ { newModel
+ | stats = Nothing
+ , expandedSections = Set.empty
+ , loadedSections = Set.empty
+ , similarStates = Dict.empty
+ }
+
+ else
+ newModel
+ in
+ ( clearedModel
+ , fetchListens newUserSlug model.limit finalOffset finalFilter finalSearch
+ )
+
+ else
+ ( { model | activeTab = ListensTab }, Cmd.none )
+
+ Tick time ->
+ if not model.loading then
+ ( { model | currentTime = Just time, loading = True }
+ , fetchListens model.userSlug model.limit model.offset model.activeFilter model.activeSearch
+ )
+
+ else
+ ( { model | currentTime = Just time }, Cmd.none )
+
+ GotTime time ->
+ ( { model | currentTime = Just time }, Cmd.none )
+
+ GotListens result ->
+ let
+ newModel =
+ case result of
+ Err err ->
+ { model | loading = False, error = Just (httpErrorToString err) }
+
+ Ok listens ->
+ { model | loading = False, listens = listens, error = Nothing }
+ in
+ ( newModel, Task.perform GotTime Time.now )
+
+ GotStats result ->
+ case result of
+ Err err ->
+ ( { model | error = Just (httpErrorToString err) }, Cmd.none )
+
+ Ok stats ->
+ ( { model | stats = Just stats }, Cmd.none )
+
+ GotSectionData section result ->
+ case result of
+ Err err ->
+ ( { model | error = Just (httpErrorToString err) }, Cmd.none )
+
+ Ok entries ->
+ ( { model
+ | expandedSections = Set.insert section model.expandedSections
+ , loadedSections = Set.insert section model.loadedSections
+ , stats = Maybe.map (patchStatSection section entries) model.stats
+ }
+ , Cmd.none
+ )
+
+ ImageError url ->
+ ( { model | failedCovers = Set.insert url model.failedCovers }, Cmd.none )
+
+ NextPage ->
+ let
+ newOffset =
+ model.offset + model.limit
+
+ page =
+ newOffset // model.limit + 1
+
+ prefix =
+ if String.isEmpty model.userSlug then
+ "/"
+
+ else
+ "/u/" ++ model.userSlug
+ in
+ ( { model | offset = newOffset, loading = True }
+ , Cmd.batch
+ [ fetchListens model.userSlug model.limit newOffset model.activeFilter model.activeSearch
+ , Nav.pushUrl model.navKey (prefix ++ "?page=" ++ String.fromInt page)
+ ]
+ )
+
+ PrevPage ->
+ let
+ newOffset =
+ max 0 (model.offset - model.limit)
+
+ page =
+ newOffset // model.limit + 1
+
+ prefix =
+ if String.isEmpty model.userSlug then
+ "/"
+
+ else
+ "/u/" ++ model.userSlug
+ in
+ ( { model | offset = newOffset, loading = True }
+ , Cmd.batch
+ [ fetchListens model.userSlug model.limit newOffset model.activeFilter model.activeSearch
+ , Nav.pushUrl model.navKey (prefix ++ "?page=" ++ String.fromInt page)
+ ]
+ )
+
+ SwitchTab tab ->
+ ( { model | activeTab = tab }
+ , case tab of
+ StatsTab ->
+ if model.stats == Nothing then
+ fetchStats model.userSlug model.statsPeriod
+
+ else
+ Cmd.none
+
+ ListensTab ->
+ Cmd.none
+
+ AboutTab ->
+ Cmd.none
+ )
+
+ SetStatsPeriod period ->
+ ( { model
+ | statsPeriod = period
+ , stats = Nothing
+ , expandedSections = Set.empty
+ , loadedSections = Set.empty
+ , showCustomInput = False
+ }
+ , fetchStats model.userSlug period
+ )
+
+ OpenCustomInput ->
+ let
+ prefill =
+ case model.statsPeriod of
+ CustomRange from to ->
+ from ++ " " ++ to
+
+ _ ->
+ model.customInput
+ in
+ ( { model | showCustomInput = True, customInput = prefill, customError = Nothing }
+ , Cmd.none
+ )
+
+ UpdateCustomInput str ->
+ ( { model | customInput = str, customError = Nothing }, Cmd.none )
+
+ ApplyCustomPeriod ->
+ let
+ parts =
+ model.customInput
+ |> String.split " "
+ |> List.filter (not << String.isEmpty)
+ in
+ case parts of
+ [ from, to ] ->
+ if String.length from /= 10 || String.length to /= 10 then
+ ( { model | customError = Just "Dates must be in YYYY-MM-DD format" }, Cmd.none )
+
+ else if from > to then
+ ( { model | customError = Just "'from' must be before 'to'" }, Cmd.none )
+
+ else
+ let
+ period =
+ CustomRange from to
+ in
+ ( { model
+ | statsPeriod = period
+ , stats = Nothing
+ , expandedSections = Set.empty
+ , loadedSections = Set.empty
+ , showCustomInput = False
+ , customError = Nothing
+ }
+ , fetchStats model.userSlug period
+ )
+
+ _ ->
+ ( { model | customError = Just "Enter two dates separated by a space" }, Cmd.none )
+
+ FilterBy field value ->
+ let
+ filter =
+ Just { field = field, value = value }
+
+ prefix =
+ if String.isEmpty model.userSlug then
+ "/"
+
+ else
+ "/u/" ++ model.userSlug
+ in
+ ( { model | activeFilter = filter, activeSearch = Nothing, searchInput = "", offset = 0, activeTab = ListensTab, loading = True }
+ , Cmd.batch
+ [ fetchListens model.userSlug model.limit 0 filter Nothing
+ , Nav.pushUrl model.navKey (prefix ++ "?page=1")
+ ]
+ )
+
+ ClearFilter ->
+ let
+ prefix =
+ if String.isEmpty model.userSlug then
+ "/"
+
+ else
+ "/u/" ++ model.userSlug
+ in
+ ( { model | activeFilter = Nothing, offset = 0, loading = True }
+ , Cmd.batch
+ [ fetchListens model.userSlug model.limit 0 Nothing model.activeSearch
+ , Nav.pushUrl model.navKey (prefix ++ "?page=1")
+ ]
+ )
+
+ UpdateSearchInput str ->
+ ( { model | searchInput = str }, Cmd.none )
+
+ SubmitSearch ->
+ let
+ q =
+ String.trim model.searchInput
+
+ prefix =
+ if String.isEmpty model.userSlug then
+ "/"
+
+ else
+ "/u/" ++ model.userSlug
+ in
+ if String.isEmpty q then
+ ( { model | activeSearch = Nothing, offset = 0, loading = True }
+ , Cmd.batch
+ [ fetchListens model.userSlug model.limit 0 Nothing Nothing
+ , Nav.pushUrl model.navKey (prefix ++ "?page=1")
+ ]
+ )
+
+ else
+ ( { model | activeSearch = Just q, activeFilter = Nothing, offset = 0, loading = True }
+ , Cmd.batch
+ [ fetchListens model.userSlug model.limit 0 Nothing (Just q)
+ , Nav.pushUrl model.navKey (prefix ++ "?page=1")
+ ]
+ )
+
+ ClearSearch ->
+ let
+ prefix =
+ if String.isEmpty model.userSlug then
+ "/"
+
+ else
+ "/u/" ++ model.userSlug
+ in
+ ( { model | searchInput = "", activeSearch = Nothing, offset = 0, loading = True }
+ , Cmd.batch
+ [ fetchListens model.userSlug model.limit 0 Nothing Nothing
+ , Nav.pushUrl model.navKey (prefix ++ "?page=1")
+ ]
+ )
+
+ HoverCover idx ->
+ ( { model | hoveredCover = Just idx }, Cmd.none )
+
+ UnhoverCover ->
+ ( { model | hoveredCover = Nothing }, Cmd.none )
+
+ ExpandSection section ->
+ ( { model | expandedSections = Set.insert section model.expandedSections }, Cmd.none )
+
+ ShowAllSection section ->
+ ( model, fetchSectionData model.userSlug model.statsPeriod section )
+
+ CollapseSection section ->
+ ( { model
+ | expandedSections = Set.remove section model.expandedSections
+ , loadedSections = Set.remove section model.loadedSections
+ }
+ , Cmd.none
+ )
+
+ FetchSimilar artist track ->
+ let
+ key =
+ artist ++ "\t" ++ track
+ in
+ if Dict.member key model.similarStates then
+ ( { model | similarStates = Dict.remove key model.similarStates }, Cmd.none )
+
+ else
+ ( { model | similarStates = Dict.insert key SimilarLoading model.similarStates }
+ , fetchSimilarTracks artist track
+ )
+
+ FetchSimilarTracks artist track result ->
+ let
+ key =
+ artist ++ "\t" ++ track
+
+ newStates =
+ case result of
+ Ok tracks ->
+ Dict.insert key (SimilarLoaded tracks) model.similarStates
+
+ Err err ->
+ Dict.insert key (SimilarError (httpErrorToString err)) model.similarStates
+ in
+ ( { model | similarStates = newStates }, Cmd.none )
+
+
+patchStatSection : String -> List StatsEntry -> Stats -> Stats
+patchStatSection section entries stats =
+ case section of
+ "artist" ->
+ { stats | artists = entries }
+
+ "track" ->
+ { stats | tracks = entries }
+
+ "genre" ->
+ { stats | genres = entries }
+
+ "label" ->
+ { stats | labels = entries }
+
+ "year" ->
+ { stats | years = entries }
+
+ _ ->
+ stats
+
+
+
+-- SUBSCRIPTIONS
+
+
+subscriptions : Model -> Sub Msg
+subscriptions _ =
+ Time.every 30000 Tick
+
+
+
+-- HTTP
diff --git a/src/Sync.purs b/src/Sync.purs
@@ -0,0 +1,273 @@
+module Sync
+ ( listenBrainzUrl
+ , lastfmTrackToListen
+ , lbSync
+ , lbSyncLoop
+ , lfSync
+ , lfSyncLoop
+ ) where
+
+import Prelude
+
+import Control.Monad.Rec.Class (forever)
+import Data.Argonaut (decodeJson, parseJson)
+import Data.Argonaut.Core (Json, toArray, toObject, toString)
+import Data.Array (length, mapMaybe, null)
+import Data.Either (Either(..))
+import Data.Foldable (foldM, for_)
+import Data.Int (fromString)
+import Data.Maybe (Maybe(..), fromMaybe)
+import Data.Time.Duration (Milliseconds(..))
+import Data.Tuple (Tuple(..))
+import Db (Connection, checkExists, getOldestTs, upsertScrobble, withTransaction)
+import Effect.Aff (Aff, delay, launchAff_, makeAff, nonCanceler, try)
+import Effect.Aff.AVar (AVar)
+import Effect.Aff.Retry (RetryStatus(..), exponentialBackoff, limitRetries, recovering)
+import Effect.Class (liftEffect)
+import Effect.Exception as Exception
+import Effect.Uncurried (mkEffectFn1)
+import Fetch (fetch, Method(GET))
+import Fetch.Argonaut.Json (fromJson)
+import Foreign.Object as Object
+import JSURI (encodeURIComponent)
+import Log as Log
+import Metrics as Metrics
+import Node.EventEmitter (EventHandle(..), on_)
+import Node.HTTP.ClientRequest as Client
+import Node.HTTP.IncomingMessage as IM
+import Node.HTTPS as HTTPS
+import Node.Stream.Aff (readableToStringUtf8)
+import Types (Listen(..), ListenBrainzResponse(..), MbidMapping(..), Payload(..), TrackMetadata(..))
+import Unsafe.Coerce (unsafeCoerce)
+
+listenBrainzUrl :: String -> String
+listenBrainzUrl username = "https://api.listenbrainz.org/1/user/" <> username <> "/listens"
+
+withRetry :: forall a. String -> Aff a -> Aff a
+withRetry label action = recovering policy [ \_ _ -> pure true ] \(RetryStatus status) -> do
+ when (status.iterNumber > 0)
+ $ Log.warn
+ $ label <> " failed, retry attempt " <> show status.iterNumber
+ action
+ where
+ policy = exponentialBackoff (Milliseconds 1000.0) <> limitRetries 5
+
+fetchListenBrainzUrl :: String -> Aff String
+fetchListenBrainzUrl url = withRetry "ListenBrainz fetch" $ makeAff \callback -> do
+ req <- HTTPS.get url
+
+ req # on_ Client.responseH \res -> do
+ launchAff_ do
+ result <- try $ readableToStringUtf8 (IM.toReadable res)
+ liftEffect $ case result of
+ Left err ->
+ callback (Left err)
+ Right body ->
+ if IM.statusCode res == 200 then
+ callback (Right body)
+ else
+ callback (Left $ Exception.error $ "ListenBrainz API returned status " <> show (IM.statusCode res))
+
+ let errorH = EventHandle "error" mkEffectFn1
+ on_ errorH (\err -> callback (Left err)) (unsafeCoerce req)
+
+ pure nonCanceler
+
+fetchLastfmPage :: String -> String -> Int -> Maybe Int -> Aff { tracks :: Array Json, totalPages :: Int }
+fetchLastfmPage apiKey lfmUser page mTo = withRetry "Last.fm fetch" do
+ let
+ toParam = case mTo of
+ Just ts -> "&to=" <> show ts
+ Nothing -> ""
+ baseUrl = "https://ws.audioscrobbler.com/2.0/?method=user.getrecenttracks&user="
+ <> (fromMaybe lfmUser $ encodeURIComponent lfmUser)
+ <> "&format=json&limit=200&page="
+ <> show page
+ <> toParam
+ url = baseUrl <> "&api_key=" <> apiKey
+ fr <- fetch url { method: GET }
+ if fr.status == 200 then do
+ json <- fromJson fr.json
+ let
+ parsed = do
+ obj <- toObject json
+ rt <- Object.lookup "recenttracks" obj >>= toObject
+ tracks <- Object.lookup "track" rt >>= toArray
+ attr <- Object.lookup "@attr" rt >>= toObject
+ totalPagesStr <- Object.lookup "totalPages" attr >>= toString
+ totalPages <- fromString totalPagesStr
+ pure { tracks, totalPages }
+ case parsed of
+ Just result -> pure result
+ Nothing -> liftEffect $ Exception.error "Last.fm: Failed to parse JSON response" # Exception.throwException
+ else do
+ liftEffect $ Exception.error ("Last.fm API returned status " <> show fr.status) # Exception.throwException
+
+lastfmTrackToListen :: Json -> Maybe Listen
+lastfmTrackToListen json = do
+ obj <- toObject json
+ trackName <- Object.lookup "name" obj >>= toString
+ artistObj <- Object.lookup "artist" obj >>= toObject
+ artistName <- Object.lookup "#text" artistObj >>= toString
+ albumObj <- Object.lookup "album" obj >>= toObject
+ let releaseName = Object.lookup "#text" albumObj >>= toString
+ let
+ releaseMbid = do
+ s <- Object.lookup "mbid" albumObj >>= toString
+ if s == "" then Nothing else Just s
+ dateObj <- Object.lookup "date" obj >>= toObject
+ utsStr <- Object.lookup "uts" dateObj >>= toString
+ ts <- fromString utsStr
+ pure $ Listen
+ { listenedAt: Just ts
+ , trackMetadata: TrackMetadata
+ { trackName: Just trackName
+ , artistName: Just artistName
+ , releaseName: releaseName
+ , genre: Nothing
+ , label: Nothing
+ , mbidMapping: Just $ MbidMapping
+ { releaseMbid: releaseMbid
+ , caaReleaseMbid: releaseMbid
+ }
+ }
+ }
+
+recordSyncSuccess :: String -> String -> Int -> Aff Unit
+recordSyncSuccess slug source n = do
+ liftEffect $ Metrics.incSyncRuns slug source "success"
+ when (n > 0) $ liftEffect $ Metrics.incSyncScrobbles slug source n
+ liftEffect $ Metrics.setSyncLastSuccess slug source
+
+lbSync :: Connection -> String -> String -> AVar Unit -> Aff Unit
+lbSync conn username slug writeLock = void do
+ Log.info $ "Starting ListenBrainz sync for " <> username
+ result <- try $ fetchListenBrainzUrl (listenBrainzUrl username <> "?count=100")
+ case result of
+ Left err -> do
+ Log.error $ "Sync fetch error: " <> Exception.message err
+ liftEffect $ Metrics.incSyncRuns slug "listenbrainz" "error"
+ Right body ->
+ case parseJson body >>= decodeJson of
+ Left err -> do
+ Log.error $ "Sync parse error: " <> show err
+ liftEffect $ Metrics.incSyncRuns slug "listenbrainz" "error"
+ Right (ListenBrainzResponse { payload: Payload { listens } }) -> do
+ Tuple added (Tuple minTs hitCount) <- withTransaction conn writeLock (processListens listens)
+ Log.info $ "ListenBrainz batch 1: added " <> show added <> ", " <> show hitCount <> " already present."
+ let allExist = hitCount == length listens && not (null listens)
+ if allExist || null listens then do
+ when (added > 0) $ Log.info $ "ListenBrainz sync complete. Added " <> show added <> " new scrobbles."
+ recordSyncSuccess slug "listenbrainz" added
+ else do
+ total <- paginateUntilDone 2 minTs added
+ Log.info $ "ListenBrainz sync complete. Added " <> show total <> " new scrobbles."
+ recordSyncSuccess slug "listenbrainz" total
+ where
+ paginateUntilDone batchNum minTs acc = case minTs of
+ Nothing ->
+ pure acc
+ Just ts -> do
+ Log.info $ "Fetching ListenBrainz batch " <> show batchNum <> " (before " <> show ts <> ")..."
+ result <- try $ fetchListenBrainzUrl (listenBrainzUrl username <> "?count=100&max_ts=" <> show ts)
+ case result of
+ Left err -> do
+ Log.error $ "Sync fetch error: " <> Exception.message err
+ pure acc
+ Right body ->
+ case parseJson body >>= decodeJson of
+ Left err -> do
+ Log.error $ "Sync parse error: " <> show err
+ pure acc
+ Right (ListenBrainzResponse { payload: Payload { listens } }) -> do
+ Tuple added (Tuple newMinTs hitCount) <- withTransaction conn writeLock (processListens listens)
+ Log.info $ "ListenBrainz batch " <> show batchNum <> ": added " <> show added <> ", " <> show hitCount <> " already present."
+ let allExist = hitCount == length listens && not (null listens)
+ if allExist || null listens then
+ pure (acc + added)
+ else
+ paginateUntilDone (batchNum + 1) newMinTs (acc + added)
+
+ processListens listens = do
+ s <- foldM step { added: 0, minTs: Nothing, hitCount: 0 } listens
+ pure $ Tuple s.added (Tuple s.minTs s.hitCount)
+ where
+ step s l@(Listen { listenedAt: Just ts }) = do
+ exists <- checkExists conn ts
+ if exists then pure s { minTs = Just ts, hitCount = s.hitCount + 1 }
+ else do
+ upsertScrobble conn l
+ pure s { added = s.added + 1, minTs = Just ts }
+ step s _ = do
+ Log.warn "Skipping scrobble without timestamp"
+ pure s
+
+lbSyncLoop :: Connection -> String -> String -> AVar Unit -> Aff Unit
+lbSyncLoop conn username slug writeLock = forever do
+ delay (Milliseconds 60000.0)
+ lbSync conn username slug writeLock
+
+lfSync :: Connection -> String -> String -> String -> AVar Unit -> Aff Unit
+lfSync conn apiKey lfmUser slug writeLock = do
+ void performLastfmSync
+ void performLastfmBackfill
+ where
+ performLastfmSync = do
+ Log.info $ "Starting Last.fm sync for " <> lfmUser
+ { tracks, totalPages } <- fetchLastfmPage apiKey lfmUser 1 Nothing
+ Tuple added hitCount <- withTransaction conn writeLock (processLastfmTracks tracks)
+ Log.info $ "Last.fm page 1/" <> show totalPages <> ": added " <> show added <> ", " <> show hitCount <> " already present."
+ let
+ validTracks = mapMaybe lastfmTrackToListen tracks
+ allExist = hitCount == length validTracks && not (null validTracks)
+ if allExist || totalPages <= 1 then do
+ when (added > 0) $ Log.info $ "Last.fm sync complete. Added " <> show added <> " new scrobbles."
+ recordSyncSuccess slug "lastfm" added
+ else do
+ total <- paginateLastfmUntilDone 2 totalPages Nothing added
+ Log.info $ "Last.fm sync complete. Added " <> show total <> " new scrobbles."
+ recordSyncSuccess slug "lastfm" total
+
+ paginateLastfmUntilDone page totalPages mTo acc
+ | page > totalPages = pure acc
+ | otherwise = do
+ Log.info $ "Fetching Last.fm page " <> show page <> "/" <> show totalPages <> "..."
+ { tracks } <- fetchLastfmPage apiKey lfmUser page mTo
+ Tuple added hitCount <- withTransaction conn writeLock (processLastfmTracks tracks)
+ Log.info $ "Last.fm page " <> show page <> "/" <> show totalPages <> ": added " <> show added <> ", " <> show hitCount <> " already present."
+ let
+ validTracks = mapMaybe lastfmTrackToListen tracks
+ allExist = hitCount == length validTracks && not (null validTracks)
+ if allExist || null tracks then pure (acc + added)
+ else paginateLastfmUntilDone (page + 1) totalPages mTo (acc + added)
+
+ performLastfmBackfill = do
+ mOldest <- getOldestTs conn
+ for_ mOldest \oldestTs -> do
+ Log.info $ "Checking for Last.fm history before " <> show oldestTs <> "..."
+ { tracks, totalPages } <- fetchLastfmPage apiKey lfmUser 1 (Just (oldestTs - 1))
+ if null tracks then
+ Log.info "No older Last.fm history found."
+ else do
+ Log.info $ "Backfilling " <> show totalPages <> " pages of Last.fm history before " <> show oldestTs
+ Tuple added hitCount <- withTransaction conn writeLock (processLastfmTracks tracks)
+ Log.info $ "Last.fm backfill page 1/" <> show totalPages <> ": added " <> show added <> ", " <> show hitCount <> " already present."
+ total <- paginateLastfmUntilDone 2 totalPages (Just (oldestTs - 1)) added
+ Log.info $ "Last.fm backfill complete. Added " <> show total <> " older scrobbles."
+
+ processLastfmTracks tracks = do
+ s <- foldM step { added: 0, hitCount: 0 } (mapMaybe lastfmTrackToListen tracks)
+ pure $ Tuple s.added s.hitCount
+ where
+ step s l@(Listen { listenedAt: Just ts }) = do
+ exists <- checkExists conn ts
+ if exists then pure s { hitCount = s.hitCount + 1 }
+ else do
+ upsertScrobble conn l
+ pure s { added = s.added + 1 }
+ step s _ = pure s
+
+lfSyncLoop :: Connection -> String -> String -> String -> AVar Unit -> Aff Unit
+lfSyncLoop conn apiKey lfmUser slug writeLock = forever do
+ delay (Milliseconds 60000.0)
+ lfSync conn apiKey lfmUser slug writeLock
diff --git a/src/Templates.purs b/src/Templates.purs
@@ -743,12 +743,7 @@ indexHtml userSlug allUsers =
<>
""";
var app = Elm.Client.init({
- node: document.getElementById('app'),
- flags: { search: window.location.search, userSlug: userSlug, allUsers: allUsers }
- });
- app.ports.pushUrl.subscribe(function(url) {
- var prefix = userSlug ? '/u/' + userSlug : '';
- history.pushState({}, '', prefix + url);
+ flags: { userSlug: userSlug, allUsers: allUsers }
});
</script>
</body>
diff --git a/src/Types.elm b/src/Types.elm
@@ -0,0 +1,149 @@
+module Types exposing (ActiveFilter, Flags, Listen, Model, Msg(..), Period(..), SimilarState(..), SimilarTrack, Stats, StatsEntry, Tab(..), UserInfo)
+
+import Browser
+import Browser.Navigation as Nav
+import Dict exposing (Dict)
+import Http
+import Set exposing (Set)
+import Time
+import Url
+
+
+type alias UserInfo =
+ { slug : String
+ , name : String
+ }
+
+
+type alias Flags =
+ { userSlug : String
+ , allUsers : List UserInfo
+ }
+
+
+
+-- TYPES
+
+
+type Tab
+ = ListensTab
+ | StatsTab
+ | AboutTab
+
+
+type Period
+ = AllTime
+ | LastDays Int
+ | CustomRange String String
+
+
+type alias ActiveFilter =
+ { field : String
+ , value : String
+ }
+
+
+type alias Listen =
+ { trackName : Maybe String
+ , artistName : Maybe String
+ , releaseName : Maybe String
+ , listenedAt : Maybe Int
+ , genre : Maybe String
+ , label : Maybe String
+ , releaseMbid : Maybe String
+ , caaReleaseMbid : Maybe String
+ }
+
+
+type alias StatsEntry =
+ { name : String
+ , count : Int
+ }
+
+
+type alias Stats =
+ { genres : List StatsEntry
+ , labels : List StatsEntry
+ , years : List StatsEntry
+ , artists : List StatsEntry
+ , tracks : List StatsEntry
+ }
+
+
+type alias SimilarTrack =
+ { artist : String
+ , track : String
+ , score : Maybe Float
+ , videoUri : Maybe String
+ }
+
+
+type SimilarState
+ = SimilarLoading
+ | SimilarLoaded (List SimilarTrack)
+ | SimilarError String
+
+
+
+-- MODEL
+
+
+type alias Model =
+ { navKey : Nav.Key
+ , listens : List Listen
+ , stats : Maybe Stats
+ , error : Maybe String
+ , loading : Bool
+ , currentTime : Maybe Time.Posix
+ , failedCovers : Set String
+ , hoveredCover : Maybe Int
+ , expandedSections : Set String
+ , loadedSections : Set String
+ , offset : Int
+ , limit : Int
+ , activeTab : Tab
+ , activeFilter : Maybe ActiveFilter
+ , statsPeriod : Period
+ , customInput : String
+ , showCustomInput : Bool
+ , customError : Maybe String
+ , userSlug : String
+ , similarStates : Dict String SimilarState
+ , allUsers : List UserInfo
+ , searchInput : String
+ , activeSearch : Maybe String
+ }
+
+
+type Msg
+ = GotListens (Result Http.Error (List Listen))
+ | GotStats (Result Http.Error Stats)
+ | GotSectionData String (Result Http.Error (List StatsEntry))
+ | Tick Time.Posix
+ | GotTime Time.Posix
+ | ImageError String
+ | NextPage
+ | PrevPage
+ | SwitchTab Tab
+ | SetStatsPeriod Period
+ | OpenCustomInput
+ | UpdateCustomInput String
+ | ApplyCustomPeriod
+ | FilterBy String String
+ | ClearFilter
+ | HoverCover Int
+ | UnhoverCover
+ | ExpandSection String
+ | ShowAllSection String
+ | CollapseSection String
+ | FetchSimilar String String
+ | FetchSimilarTracks String String (Result Http.Error (List SimilarTrack))
+ | UpdateSearchInput String
+ | SubmitSearch
+ | ClearSearch
+ | UrlRequested Browser.UrlRequest
+ | UrlChanged Url.Url
+
+
+
+-- UPDATE
diff --git a/src/View.elm b/src/View.elm
@@ -0,0 +1,700 @@
+module View exposing (view)
+
+import Browser
+import Dict exposing (Dict)
+import Html exposing (Html, a, button, div, h1, h2, img, input, li, p, span, strong, text, ul)
+import Html.Attributes as Attr exposing (class, disabled, href, placeholder, src, style, target, type_, value)
+import Html.Events exposing (on, onClick, onInput)
+import Json.Decode as D
+import Set exposing (Set)
+import Time
+import Types exposing (Listen, Model, Msg(..), Period(..), SimilarState(..), SimilarTrack, Stats, StatsEntry, Tab(..), UserInfo)
+import Url
+
+
+
+-- VIEW
+
+
+view : Model -> Browser.Document Msg
+view model =
+ { title = "scrobbler"
+ , body =
+ [ div [ class "container" ]
+ [ h1 [] [ text "scrobbler" ]
+ , div [ class "tabs" ]
+ [ a
+ [ class
+ ("tab-btn"
+ ++ (if model.activeTab == ListensTab then
+ " active"
+
+ else
+ ""
+ )
+ )
+ , href
+ (if model.userSlug == "" then
+ "/"
+
+ else
+ "/u/" ++ model.userSlug
+ )
+ ]
+ [ text "listens" ]
+ , button
+ [ class
+ ("tab-btn"
+ ++ (if model.activeTab == StatsTab then
+ " active"
+
+ else
+ ""
+ )
+ )
+ , onClick (SwitchTab StatsTab)
+ ]
+ [ text "stats" ]
+ , button
+ [ class
+ ("tab-btn"
+ ++ (if model.activeTab == AboutTab then
+ " active"
+
+ else
+ ""
+ )
+ )
+ , onClick (SwitchTab AboutTab)
+ ]
+ [ text "about" ]
+ ]
+ , case model.activeTab of
+ ListensTab ->
+ div []
+ [ div [ class "search-bar" ]
+ [ input
+ [ type_ "text"
+ , class "search-input"
+ , placeholder "search by track, artist, album or label"
+ , value model.searchInput
+ , onInput UpdateSearchInput
+ , onEnter SubmitSearch
+ ]
+ []
+ , button [ class "search-btn", onClick SubmitSearch ] [ text "search" ]
+ , case model.activeSearch of
+ Just _ ->
+ button [ class "filter-clear", onClick ClearSearch ] [ text "✕ clear" ]
+
+ Nothing ->
+ text ""
+ ]
+ , case model.activeFilter of
+ Nothing ->
+ text ""
+
+ Just { field, value } ->
+ div [ class "filter-banner" ]
+ [ span [ class "filter-label" ]
+ [ text (field ++ ": ")
+ , strong [] [ text value ]
+ ]
+ , button [ class "filter-clear", onClick ClearFilter ]
+ [ text "✕ clear" ]
+ ]
+ , renderContent model
+ , div [ class "pagination" ]
+ [ button
+ [ class "page-btn"
+ , disabled (model.offset == 0 || model.loading)
+ , onClick PrevPage
+ ]
+ [ text "Previous" ]
+ , div [ class "page-indicator" ]
+ [ text ("Page " ++ String.fromInt (model.offset // model.limit + 1)) ]
+ , button
+ [ class "page-btn"
+ , disabled (List.length model.listens < model.limit || model.loading)
+ , onClick NextPage
+ ]
+ [ text "Next" ]
+ ]
+ ]
+
+ StatsTab ->
+ div []
+ [ renderPeriodSelector model.statsPeriod model.showCustomInput model.customInput model.customError
+ , renderStatsView model.expandedSections model.loadedSections model.stats
+ ]
+
+ AboutTab ->
+ renderAboutView model.userSlug model.allUsers
+ ]
+ ]
+ }
+
+
+renderContent : Model -> Html Msg
+renderContent model =
+ if model.loading && List.isEmpty model.listens then
+ ul [] [ li [ class "loading" ] [ text "⏳" ] ]
+
+ else
+ case model.error of
+ Just err ->
+ ul [] [ li [ class "error" ] [ text err ] ]
+
+ Nothing ->
+ div [ class "tracks-with-similar" ]
+ (List.indexedMap
+ (\idx listen ->
+ let
+ artist =
+ Maybe.withDefault "" listen.artistName
+
+ trackName =
+ Maybe.withDefault "" listen.trackName
+
+ key =
+ artist ++ "\t" ++ trackName
+ in
+ div [ class "track-with-similar-container" ]
+ [ ul [ class "track-item" ]
+ [ renderListen model.userSlug model.currentTime model.failedCovers model.hoveredCover model.similarStates idx listen ]
+ , renderSimilarPanel model.similarStates key
+ ]
+ )
+ model.listens
+ )
+
+
+renderListen : String -> Maybe Time.Posix -> Set String -> Maybe Int -> Dict String SimilarState -> Int -> Listen -> Html Msg
+renderListen userSlug currentTime failedCovers hoveredCover similarStates idx listen =
+ let
+ artist =
+ Maybe.withDefault "" listen.artistName
+
+ trackName =
+ Maybe.withDefault "" listen.trackName
+
+ release =
+ Maybe.withDefault "" listen.releaseName
+
+ key =
+ artist ++ "\t" ++ trackName
+
+ mbid =
+ case listen.caaReleaseMbid of
+ Just m ->
+ Just m
+
+ Nothing ->
+ listen.releaseMbid
+
+ coverUrl =
+ "/cover?user="
+ ++ userSlug
+ ++ "&artist="
+ ++ Url.percentEncode artist
+ ++ "&release="
+ ++ Url.percentEncode release
+ ++ (case mbid of
+ Just m ->
+ "&mbid=" ++ m
+
+ Nothing ->
+ ""
+ )
+
+ isZoomed =
+ hoveredCover == Just idx
+
+ isActive =
+ Dict.member key similarStates
+ in
+ li [ class "success" ]
+ [ div [ class "track-info" ]
+ [ div [ class "track-name" ]
+ [ button [ class "track-link", onClick (FilterBy "track" (Maybe.withDefault "Unknown Track" listen.trackName)) ] [ text (Maybe.withDefault "Unknown Track" listen.trackName) ] ]
+ , div [ class "track-artist" ] [ button [ class "artist-link", onClick (FilterBy "artist" artist) ] [ text artist ] ]
+ , div [ class "track-time" ]
+ [ span []
+ (button [ class "album-link", onClick (FilterBy "album" release) ] [ text release ]
+ :: (case listen.label of
+ Just l ->
+ [ text " • "
+ , button [ class "label-link", onClick (FilterBy "label" l) ] [ text l ]
+ ]
+
+ Nothing ->
+ []
+ )
+ ++ [ text (" • " ++ timeAgo currentTime listen.listenedAt) ]
+ )
+ ]
+ ]
+ , div [ class "cover-wrapper" ]
+ [ if Set.member coverUrl failedCovers then
+ text ""
+
+ else
+ img
+ [ class
+ ("track-cover"
+ ++ (if isZoomed then
+ " zoomed"
+
+ else
+ ""
+ )
+ )
+ , src coverUrl
+ , Attr.alt release
+ , on "error" (D.succeed (ImageError coverUrl))
+ , onClick
+ (if isZoomed then
+ UnhoverCover
+
+ else
+ HoverCover idx
+ )
+ ]
+ []
+ , case listen.genre of
+ Just g ->
+ div [ class "genre-tag" ] [ text g ]
+
+ Nothing ->
+ text ""
+ , if artist /= "" && trackName /= "" then
+ button
+ [ class
+ ("similar-btn"
+ ++ (if isActive then
+ " active"
+
+ else
+ ""
+ )
+ )
+ , onClick (FetchSimilar artist trackName)
+ ]
+ [ text "similar" ]
+
+ else
+ text ""
+ ]
+ ]
+
+
+renderSimilarPanel : Dict String SimilarState -> String -> Html Msg
+renderSimilarPanel similarStates key =
+ case Dict.get key similarStates of
+ Nothing ->
+ text ""
+
+ Just SimilarLoading ->
+ div [ class "similar-panel" ]
+ [ div [ class "similar-loading" ] [ text "⏳" ] ]
+
+ Just (SimilarError err) ->
+ div [ class "similar-panel" ]
+ [ div [ class "similar-error" ] [ text err ] ]
+
+ Just (SimilarLoaded tracks) ->
+ div [ class "similar-panel" ]
+ [ if List.isEmpty tracks then
+ div [ class "similar-empty" ] [ text "no similar songs found" ]
+
+ else
+ div [] (List.map renderSimilarTrack tracks)
+ ]
+
+
+renderSimilarTrack : SimilarTrack -> Html Msg
+renderSimilarTrack track =
+ div [ class "similar-track" ]
+ [ div [ class "similar-track-info" ]
+ [ div [ class "similar-track-name" ] [ text track.track ]
+ , div [ class "similar-track-artist" ] [ text track.artist ]
+ ]
+ , case track.score of
+ Just score ->
+ span [ class "similar-score" ]
+ [ text (String.fromInt (round (score * 100)) ++ "%") ]
+
+ Nothing ->
+ text ""
+ , case track.videoUri of
+ Just link ->
+ a [ class "similar-link", href link, target "_blank" ]
+ [ text "▶" ]
+
+ Nothing ->
+ text ""
+ ]
+
+
+renderStatsView : Set String -> Set String -> Maybe Stats -> Html Msg
+renderStatsView expandedSections loadedSections mStats =
+ case mStats of
+ Nothing ->
+ div [ class "loading" ] [ text "⏳" ]
+
+ Just stats ->
+ div []
+ [ renderStatSection expandedSections loadedSections (Just "artist") "top artists" stats.artists
+ , renderStatSection expandedSections loadedSections Nothing "top tracks" stats.tracks
+ , renderStatSection expandedSections loadedSections (Just "genre") "genres" stats.genres
+ , renderStatSection expandedSections loadedSections (Just "label") "labels" stats.labels
+ , renderStatSection expandedSections loadedSections (Just "year") "years" stats.years
+ ]
+
+
+renderStatSection : Set String -> Set String -> Maybe String -> String -> List StatsEntry -> Html Msg
+renderStatSection expandedSections loadedSections mField title entries =
+ let
+ sectionKey =
+ Maybe.withDefault title mField
+
+ expanded =
+ Set.member sectionKey expandedSections
+
+ loaded =
+ Set.member sectionKey loadedSections
+
+ visible =
+ if loaded then
+ entries
+
+ else if expanded then
+ List.take 50 entries
+
+ else
+ List.take 10 entries
+
+ maxCount =
+ entries
+ |> List.map .count
+ |> List.maximum
+ |> Maybe.withDefault 1
+
+ n =
+ List.length entries
+
+ footer =
+ if loaded then
+ if n > 10 then
+ button [ class "show-all-btn", onClick (CollapseSection sectionKey) ] [ text "show less" ]
+
+ else
+ text ""
+
+ else if expanded then
+ if n >= 50 then
+ span []
+ [ button [ class "show-all-btn", onClick (ShowAllSection sectionKey) ] [ text "show all" ]
+ , text " · "
+ , button [ class "show-all-btn", onClick (CollapseSection sectionKey) ] [ text "show less" ]
+ ]
+
+ else
+ button [ class "show-all-btn", onClick (CollapseSection sectionKey) ] [ text "show less" ]
+
+ else if n > 10 then
+ button [ class "show-all-btn", onClick (ExpandSection sectionKey) ] [ text "show more" ]
+
+ else
+ text ""
+ in
+ div [ class "stats-section" ]
+ [ h2 [] [ text title ]
+ , if List.isEmpty entries then
+ div [ class "stats-empty" ] [ text "beyond here lies nothing" ]
+
+ else
+ ul [] (List.map (renderStatEntry maxCount mField) visible)
+ , footer
+ ]
+
+
+renderStatEntry : Int -> Maybe String -> StatsEntry -> Html Msg
+renderStatEntry maxCount mField entry =
+ let
+ barPct =
+ entry.count * 100 // maxCount
+
+ rowAttrs =
+ case mField of
+ Just field ->
+ [ class "stat-row clickable", onClick (FilterBy field entry.name) ]
+
+ Nothing ->
+ [ class "stat-row" ]
+ in
+ li rowAttrs
+ [ div [ class "stat-bar", style "width" (String.fromInt barPct ++ "%") ] []
+ , span [ class "stat-name" ] [ text entry.name ]
+ , span [ class "stat-count" ] [ text (String.fromInt entry.count) ]
+ ]
+
+
+renderPeriodSelector : Period -> Bool -> String -> Maybe String -> Html Msg
+renderPeriodSelector current showInput customVal mError =
+ let
+ isCustom =
+ case current of
+ CustomRange _ _ ->
+ True
+
+ _ ->
+ False
+
+ namedBtn target label =
+ button
+ [ class
+ ("period-btn"
+ ++ (if current == target then
+ " active"
+
+ else
+ ""
+ )
+ )
+ , onClick (SetStatsPeriod target)
+ ]
+ [ text label ]
+
+ customBtn =
+ button
+ [ class
+ ("period-btn"
+ ++ (if isCustom then
+ " active"
+
+ else
+ ""
+ )
+ )
+ , onClick OpenCustomInput
+ ]
+ [ text "custom" ]
+
+ daysBtn n =
+ let
+ label =
+ case n of
+ 7 ->
+ "1w"
+
+ 14 ->
+ "2w"
+
+ 30 ->
+ "1m"
+
+ 90 ->
+ "3m"
+
+ 180 ->
+ "6m"
+
+ 365 ->
+ "1y"
+
+ _ ->
+ String.fromInt n ++ "d"
+ in
+ button
+ [ class
+ ("period-btn"
+ ++ (if current == LastDays n then
+ " active"
+
+ else
+ ""
+ )
+ )
+ , onClick (SetStatsPeriod (LastDays n))
+ ]
+ [ text label ]
+ in
+ div []
+ [ div [ class "period-selector" ]
+ ([ namedBtn AllTime "all time", customBtn ]
+ ++ List.map daysBtn [ 7, 14, 30, 90, 180, 365 ]
+ )
+ , if showInput || isCustom then
+ div []
+ [ div [ class "custom-range" ]
+ [ input
+ [ type_ "text"
+ , class
+ ("custom-range-input"
+ ++ (if mError /= Nothing then
+ " error"
+
+ else
+ ""
+ )
+ )
+ , placeholder "2023-01-01 2026-01-01"
+ , value customVal
+ , onInput UpdateCustomInput
+ ]
+ []
+ , button [ class "period-btn", onClick ApplyCustomPeriod ]
+ [ text "apply" ]
+ ]
+ , case mError of
+ Just err ->
+ div [ class "custom-range-error" ] [ text err ]
+
+ Nothing ->
+ text ""
+ ]
+
+ else
+ text ""
+ ]
+
+
+onEnter : msg -> Html.Attribute msg
+onEnter msg =
+ on "keydown"
+ (D.field "key" D.string
+ |> D.andThen
+ (\key ->
+ if key == "Enter" then
+ D.succeed msg
+
+ else
+ D.fail "not enter"
+ )
+ )
+
+
+
+-- HELPERS
+
+
+timeAgo : Maybe Time.Posix -> Maybe Int -> String
+timeAgo mNow mTimestamp =
+ case ( mNow, mTimestamp ) of
+ ( Just now, Just ts ) ->
+ let
+ nowSecs =
+ Time.posixToMillis now // 1000
+
+ diff =
+ nowSecs - ts
+ in
+ if diff < 60 then
+ "just now"
+
+ else if diff < 3600 then
+ let
+ mins =
+ diff // 60
+ in
+ String.fromInt mins
+ ++ " minute"
+ ++ (if mins > 1 then
+ "s"
+
+ else
+ ""
+ )
+ ++ " ago"
+
+ else if diff < 86400 then
+ let
+ hours =
+ diff // 3600
+ in
+ String.fromInt hours
+ ++ " hour"
+ ++ (if hours > 1 then
+ "s"
+
+ else
+ ""
+ )
+ ++ " ago"
+
+ else
+ let
+ days =
+ diff // 86400
+ in
+ String.fromInt days
+ ++ " day"
+ ++ (if days > 1 then
+ "s"
+
+ else
+ ""
+ )
+ ++ " ago"
+
+ _ ->
+ "unknown time"
+
+
+renderAboutView : String -> List UserInfo -> Html Msg
+renderAboutView currentSlug allUsers =
+ let
+ otherUsers =
+ List.filter (\u -> u.slug /= currentSlug) allUsers
+
+ userLink { slug, name } =
+ let
+ url =
+ if slug == "" then
+ "/"
+
+ else
+ "/u/" ++ slug
+ in
+ li [] [ a [ href url ] [ text name ] ]
+
+ extLink url label =
+ a [ href url, target "_blank", class "about-link" ] [ text label ]
+ in
+ div []
+ [ p [ class "about-lead" ]
+ [ text "corpus is a self-hosted listen history proxy that syncs scrobbles from "
+ , extLink "https://listenbrainz.org" "ListenBrainz"
+ , text " and "
+ , extLink "https://www.last.fm" "Last.fm."
+ ]
+ , div [ class "stats-section" ]
+ [ h2 [] [ text "features" ]
+ , ul [ class "about-list" ]
+ [ li [] [ text "searchable listen history with pagination" ]
+ , li [] [ text "stats by artist, track, label, year, and genre" ]
+ , li [] [ text "filter listens by label, artist, genre, or year" ]
+ , li [] [ text "cover art from Cover Art Archive, Last.fm, and Discogs" ]
+ , li [] [ text "similar track discovery via cosine.club" ]
+ , li [] [ text "metadata enrichment via MusicBrainz, Last.fm, and Discogs" ]
+ ]
+ ]
+ , div [ class "stats-section" ]
+ [ h2 [] [ text "links" ]
+ , p [ class "about-meta" ]
+ [ div [] [ extLink "https://instagram.com/counterpoint303" "counterpoint" ]
+ , div [] [ extLink "https://github.com/mtmn/corpus" "github repo" ]
+ , div [] [ extLink "https://mtmn.name" "mtmn.name" ]
+ ]
+ ]
+ , if List.isEmpty otherUsers then
+ text ""
+
+ else
+ div [ class "stats-section" ]
+ [ h2 [] [ text "friends" ]
+ , ul [ class "about-users" ]
+ (List.map userLink otherUsers)
+ ]
+ ]
diff --git a/test/Main.purs b/test/Main.purs
@@ -15,7 +15,9 @@ import Types (Listen(..), ListenBrainzResponse(..), MbidMapping(..), Payload(..)
import Db (FilterField(..), connect, initDb, checkExists, upsertScrobble, getScrobbles, initReleaseMetadata, upsertReleaseMetadata, getStats, dbBaseName, getOldestTs, getUnenrichedMbids, getEmptyGenreMbids, getArtistReleasesByMbids, touchGenreCheckedAt)
import Data.Argonaut.Core (Json)
import Foreign.Object as Object
-import Main (sanitizeKey, listenBrainzUrl, lastfmTrackToListen, parseFilterField)
+import Main (parseFilterField)
+import Cover (sanitizeKey)
+import Sync (listenBrainzUrl, lastfmTrackToListen)
import S3 (getS3Url)
main :: Effect Unit
diff --git a/users.dhall b/users.dhall
@@ -6,7 +6,6 @@ let UserConfig =
, coverCacheEnabled : Bool
, backupEnabled : Bool
, backupIntervalHours : Natural
- , initialSync : Bool
}
let defaults
@@ -18,7 +17,6 @@ let defaults
, coverCacheEnabled = True
, backupEnabled = False
, backupIntervalHours = 24
- , initialSync = False
}
in { users =
@@ -37,7 +35,6 @@ in { users =
with lastfmUser = Some "mtmnn"
with databaseFile = "corpus-lastfm-mtmnn.db"
with backupEnabled = True
- with initialSync = True
}
]
}
diff --git a/users.json b/users.json
@@ -6,7 +6,6 @@
"backupIntervalHours": 24,
"coverCacheEnabled": true,
"databaseFile": "corpus-mtmn.db",
- "initialSync": false,
"listenbrainzUser": "mtmn"
},
"name": "mtmn",
@@ -18,7 +17,6 @@
"backupIntervalHours": 24,
"coverCacheEnabled": true,
"databaseFile": "corpus-lastfm-mtmnn.db",
- "initialSync": true,
"lastfmUser": "mtmnn"
},
"name": "mtmn (last.fm)",
