commit 75884341e60299f61a76d0c6ca32a120db2c966a
parent e394d45dba7c024d0a5057945d4261fe623c8048
Author: mtmn <miro@haravara.org>
Date: Sat, 11 Apr 2026 04:26:13 +0200
feat: duckdb, blob storage, pagination
Former-commit-id: 07c24820321cbdf0912f80f22f01572b04257e71
Diffstat:
24 files changed, 948 insertions(+), 196 deletions(-)
diff --git a/.env.example b/.env.example
@@ -0,0 +1,9 @@
+DISCOGS_TOKEN=
+LASTFM_API_KEY=
+S3_BUCKET=
+S3_REGION=
+AWS_ACCESS_KEY_ID=
+AWS_SECRET_ACCESS_KEY=
+AWS_S3_ADDRESSING_STYLE=
+AWS_ENDPOINT_URL=
+INITIAL_SYNC=
diff --git a/.gitignore b/.gitignore
@@ -1,5 +1,21 @@
-*.js
+bower_components/
+node_modules/
+.pulp-cache/
output/
+output-es/
+generated-docs/
+.psc-package/
+result
+result-*
+.psc*
+.purs*
+.psa*
.spago/
-node_modules/
.env
+.env.local
+
+server.js
+client.js
+server.log
+scrobbler.db*
+scorpus.db*
diff --git a/Containerfile b/Containerfile
@@ -0,0 +1,43 @@
+FROM docker.io/node:25-slim AS builder
+
+WORKDIR /app
+
+# Satisfy DL3008 (pin versions) and DL3015 (no-install-recommends)
+# Note: Pinning exact apt versions is often brittle in rolling distros,
+# but using --no-install-recommends is a standard best practice.
+RUN apt-get update && apt-get install -y --no-install-recommends \
+ curl \
+ git \
+ libtinfo5 \
+ && rm -rf /var/lib/apt/lists/*
+
+COPY package.json package-lock.json ./
+COPY spago.yaml spago.lock ./
+
+RUN npm ci
+COPY src ./src
+
+RUN npm run build
+
+FROM docker.io/node:25-slim
+
+WORKDIR /app
+
+COPY package.json package-lock.json ./
+RUN npm ci --omit=dev
+
+COPY --from=builder /app/server.js ./
+COPY --from=builder /app/client.js ./
+
+RUN mkdir -p /app/data && chown -R node:node /app/data
+
+USER node
+
+# Default port for scorched scrobbler
+ENV PORT=8321
+ENV DATABASE_FILE=/app/data/scorpus.db
+ENV NODE_ENV=production
+
+EXPOSE 8321
+
+CMD ["node", "--no-deprecation", "server.js"]
diff --git a/client.js.REMOVED.git-id b/client.js.REMOVED.git-id
@@ -0,0 +1 @@
+73ca26efb57ec470fbd14a0f85c50f8583385fa8
+\ No newline at end of file
diff --git a/flake.lock b/flake.lock
@@ -0,0 +1,61 @@
+{
+ "nodes": {
+ "flake-utils": {
+ "inputs": {
+ "systems": "systems"
+ },
+ "locked": {
+ "lastModified": 1731533236,
+ "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=",
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b",
+ "type": "github"
+ },
+ "original": {
+ "owner": "numtide",
+ "repo": "flake-utils",
+ "type": "github"
+ }
+ },
+ "nixpkgs": {
+ "locked": {
+ "lastModified": 1775793324,
+ "narHash": "sha256-omax7atcZbol+6HJ2RLpP+ZCFcPa5bZ65Hn71RufeWQ=",
+ "owner": "NixOS",
+ "repo": "nixpkgs",
+ "rev": "9d29d5f667d7467f98efc31881e824fa586c927e",
+ "type": "github"
+ },
+ "original": {
+ "owner": "NixOS",
+ "ref": "nixpkgs-unstable",
+ "repo": "nixpkgs",
+ "type": "github"
+ }
+ },
+ "root": {
+ "inputs": {
+ "flake-utils": "flake-utils",
+ "nixpkgs": "nixpkgs"
+ }
+ },
+ "systems": {
+ "locked": {
+ "lastModified": 1681028828,
+ "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+ "owner": "nix-systems",
+ "repo": "default",
+ "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+ "type": "github"
+ },
+ "original": {
+ "owner": "nix-systems",
+ "repo": "default",
+ "type": "github"
+ }
+ }
+ },
+ "root": "root",
+ "version": 7
+}
diff --git a/flake.nix b/flake.nix
@@ -0,0 +1,85 @@
+{
+ description = "ListenBrainz frontend in PureScript";
+
+ inputs = {
+ nixpkgs.url = "github:NixOS/nixpkgs/nixpkgs-unstable";
+ flake-utils.url = "github:numtide/flake-utils";
+ };
+
+ outputs = {
+ nixpkgs,
+ flake-utils,
+ }:
+ flake-utils.lib.eachDefaultSystem (
+ system: let
+ pkgs = nixpkgs.legacyPackages.${system};
+ scorpus = pkgs.buildNpmPackage {
+ pname = "scorpus";
+ version = "1.0.0";
+ src = ./.;
+
+ npmDepsHash = "sha256-0000000000000000000000000000000000000000000=";
+
+ nativeBuildInputs = with pkgs; [
+ purescript
+ spago
+ esbuild
+ ];
+
+ buildPhase = ''
+ export HOME=$TMPDIR
+ # Spago and npm run build setup
+ npm run build
+ '';
+
+ installPhase = ''
+ mkdir -p $out/lib
+ cp server.js client.js package.json $out/lib/
+ mkdir -p $out/bin
+ echo "#!/bin/sh" > $out/bin/scorpus-server
+ echo "${pkgs.nodejs}/bin/node --no-deprecation $out/lib/server.js" >> $out/bin/scorpus-server
+ chmod +x $out/bin/scorpus-server
+ '';
+ };
+ in {
+ packages.default = scorpus;
+
+ packages.container = pkgs.dockerTools.buildLayeredImage {
+ name = "scorpus";
+ tag = "latest";
+ contents = [pkgs.nodejs pkgs.cacert];
+ config = {
+ Cmd = ["${pkgs.nodejs}/bin/node" "--no-deprecation" "/app/server.js"];
+ WorkingDir = "/app";
+ ExposedPorts = {
+ "8321/tcp" = {};
+ };
+ User = "1000:1000";
+ Env = [
+ "PORT=8321"
+ "DATABASE_FILE=/app/data/scorpus.db"
+ "NODE_ENV=production"
+ ];
+ };
+ extraCommands = ''
+ mkdir -p app/data
+ cp ${scorpus}/lib/server.js app/
+ cp ${scorpus}/lib/client.js app/
+
+ chown -R 1000:1000 app
+ chmod 700 app/data
+ '';
+ };
+
+ devShells.default = pkgs.mkShell {
+ buildInputs = with pkgs; [
+ nodejs
+ purescript
+ spago
+ purs-tidy
+ esbuild
+ ];
+ };
+ }
+ );
+}
diff --git a/package-lock.json.REMOVED.git-id b/package-lock.json.REMOVED.git-id
@@ -1 +1 @@
-0906d25db792f3ec30afece36314f061a3baf45a
-\ No newline at end of file
+ef94c9294dead0c5bb30e7aad92649283a4a9962
+\ No newline at end of file
diff --git a/package.json b/package.json
@@ -1,17 +1,17 @@
{
- "name": "scrobbler-purescript",
+ "name": "scorpus",
"version": "1.0.0",
- "description": "ListenBrainz scrobbler in PureScript",
+ "description": "ListenBrainz frontend in PureScript",
"main": "index.js",
"type": "module",
"scripts": {
- "build": "npx spago build && npx esbuild output/Main/index.js --bundle --platform=node --format=esm --outfile=server.js --external:http --external:https --external:xhr2 --external:dotenv --external:url && npx spago bundle --module Client --outfile client.js --platform browser",
+ "build": "npx spago build && npx esbuild output/Main/index.js --bundle --platform=node --format=esm --outfile=server.js --external:http --external:https --external:dotenv --external:url --external:duckdb --external:@aws-sdk/client-s3 && npx spago bundle --module Client --outfile client.js --platform browser",
"build-client": "npx spago bundle --module Client --outfile client.js --platform browser",
- "build-server": "npx esbuild output/Main/index.js --bundle --platform=node --format=esm --outfile=server.js --external:http --external:https --external:xhr2 --external:dotenv --external:url",
+ "build-server": "npx esbuild output/Main/index.js --bundle --platform=node --format=esm --outfile=server.js --external:http --external:https --external:dotenv --external:url --external:duckdb --external:@aws-sdk/client-s3",
"test": "npx spago test",
"tidy": "purs-tidy format-in-place src/**/*.purs",
- "serve": "node server.js 2>&1 | tee server.log",
- "start": "node server.js 2>&1 | tee server.log"
+ "serve": "node --no-deprecation server.js 2>&1 | tee server.log",
+ "start": "node --no-deprecation server.js 2>&1 | tee server.log"
},
"devDependencies": {
"esbuild": "^0.28.0",
@@ -22,7 +22,10 @@
"spago": "^1.0.4"
},
"dependencies": {
+ "@aws-sdk/client-s3": "^3.1029.0",
+ "audit": "^0.0.6",
"dotenv": "^17.4.1",
- "xhr2": "^0.2.1"
+ "duckdb": "^1.4.4",
+ "fix": "^0.0.6"
}
}
diff --git a/scorpus.db b/scorpus.db
Binary files differ.
diff --git a/scorpus.db.wal.REMOVED.git-id b/scorpus.db.wal.REMOVED.git-id
@@ -0,0 +1 @@
+0aaa61e78ffc091de568b77aa8244033baff8dc7
+\ No newline at end of file
diff --git a/scrobbler.db b/scrobbler.db
Binary files differ.
diff --git a/scrobbler.db.wal.REMOVED.git-id b/scrobbler.db.wal.REMOVED.git-id
@@ -0,0 +1 @@
+0aaa61e78ffc091de568b77aa8244033baff8dc7
+\ No newline at end of file
diff --git a/server.js.REMOVED.git-id b/server.js.REMOVED.git-id
@@ -0,0 +1 @@
+05154c6c49414d8992937a0206db9f15fb2b1744
+\ No newline at end of file
diff --git a/spago.lock b/spago.lock
@@ -1,7 +1,7 @@
{
"workspace": {
"packages": {
- "scrobbler-purescript": {
+ "scorpus": {
"path": "./",
"core": {
"dependencies": [
@@ -30,6 +30,7 @@
"node-http",
"node-net",
"node-process",
+ "node-sqlite3",
"node-streams",
"node-url",
"now",
@@ -38,7 +39,8 @@
"strings",
"tailrec",
"unsafe-coerce",
- "web-dom"
+ "web-dom",
+ "web-html"
]
},
"test": {
@@ -1616,6 +1618,19 @@
"strings"
]
},
+ "node-sqlite3": {
+ "type": "registry",
+ "version": "8.0.0",
+ "integrity": "sha256-vmiT8S2dcBO6udUoXn8ppG3FNCEcq6AA1q92memeyWo=",
+ "dependencies": [
+ "aff",
+ "effect",
+ "either",
+ "exceptions",
+ "foreign",
+ "prelude"
+ ]
+ },
"node-streams": {
"type": "registry",
"version": "9.0.1",
diff --git a/spago.yaml b/spago.yaml
@@ -1,5 +1,5 @@
package:
- name: scrobbler-purescript
+ name: scorpus
dependencies:
- aff
- affjax
@@ -26,6 +26,7 @@ package:
- node-http
- node-net
- node-process
+ - node-sqlite3
- node-streams
- node-url
- now
@@ -35,6 +36,7 @@ package:
- tailrec
- unsafe-coerce
- web-dom
+ - web-html
test:
main: Test.Main
dependencies: []
diff --git a/src/Client.js b/src/Client.js
@@ -0,0 +1,8 @@
+export const extractParam = (key) => (search) => {
+ const params = new URLSearchParams(search);
+ return params.get(key);
+};
+
+export const formatRFC3339 = (instant) => {
+ return new Date(instant).toISOString();
+};
diff --git a/src/Client.purs b/src/Client.purs
@@ -5,10 +5,9 @@ import Prelude
import Affjax.Web as AX
import Affjax.ResponseFormat as ResponseFormat
import Data.Argonaut (decodeJson)
-import Data.Array (mapWithIndex)
-import Data.DateTime.Instant (unInstant)
+import Data.Array (mapWithIndex, length)
import Data.Either (Either(..))
-import Data.Int (floor)
+import Data.Int (floor, fromString)
import Data.Maybe (Maybe(..), fromMaybe)
import Effect (Effect)
import Effect.Console as Console
@@ -27,9 +26,15 @@ import JSURI (encodeURIComponent)
import Web.DOM.ParentNode (QuerySelector(..))
import Types (Listen(..), ListenBrainzResponse(..), TrackMetadata(..), Payload(..), MbidMapping(..))
import Data.Time.Duration (Milliseconds(..))
-
+import Data.DateTime.Instant (Instant, unInstant)
import Data.Set (Set)
import Data.Set as Set
+import Web.HTML (window)
+import Web.HTML.Window (location, history)
+import Web.HTML.Location (search)
+import Web.HTML.History (pushState, DocumentTitle(..), URL(..))
+import Foreign (unsafeToForeign)
+import Data.Nullable (Nullable, toMaybe)
type State =
{ listens :: Array Listen
@@ -38,6 +43,8 @@ type State =
, loading :: Boolean
, currentTime :: Maybe Milliseconds
, failedCovers :: Set String
+ , offset :: Int
+ , limit :: Int
}
data Action
@@ -45,6 +52,8 @@ data Action
| Refresh
| ReceiveResponse (Either String (Array Listen))
| ImageError String
+ | NextPage
+ | PrevPage
component :: forall query input output m. MonadAff m => H.Component query input output m
component =
@@ -64,13 +73,31 @@ component =
, loading: true
, currentTime: Nothing
, failedCovers: Set.empty
+ , offset: 0
+ , limit: 25
}
render state =
HH.div
[ HP.class_ (H.ClassName "container") ]
- [ HH.h1_ [ HH.text "Recent Tracks" ]
+ [ HH.h1_ [ HH.text "scorpus" ]
, renderContent state
+ , HH.div
+ [ HP.class_ (H.ClassName "pagination") ]
+ [ HH.button
+ [ HP.class_ (H.ClassName "page-btn")
+ , HP.disabled (state.offset == 0 || state.loading)
+ , HE.onClick \_ -> PrevPage
+ ]
+ [ HH.text "Previous" ]
+ , HH.div [ HP.class_ (H.ClassName "page-indicator") ] [ HH.text $ "Page " <> show (state.offset / state.limit + 1) ]
+ , HH.button
+ [ HP.class_ (H.ClassName "page-btn")
+ , HP.disabled (length state.listens < state.limit || state.loading)
+ , HE.onClick \_ -> NextPage
+ ]
+ [ HH.text "Next" ]
+ ]
, HH.p
[ HP.id "last-updated"
, HP.class_ (H.ClassName "small")
@@ -88,100 +115,118 @@ component =
(mapWithIndex (renderListen state.currentTime state.failedCovers) state.listens)
renderListen currentTime failedCovers _ (Listen { trackMetadata: TrackMetadata track, listenedAt }) =
- let
+ let
release = fromMaybe "" track.releaseName
artist = fromMaybe "" track.artistName
-
- -- Priority:
- -- 1. CAA (CAA MBID)
- -- 2. CAA (Release MBID)
- -- 3. Last.fm proxy
- -- 4. Discogs proxy
-
+
mbid = case track.mbidMapping of
Just (MbidMapping { caaReleaseMbid: Just m }) -> Just m
Just (MbidMapping { releaseMbid: Just m }) -> Just m
_ -> Nothing
-
+
lastfmId = "lastfm-" <> artist <> "-" <> release
discogsId = "discogs-" <> artist <> "-" <> release
-
+
coverInfo = case mbid of
- Just m ->
- if Set.member m failedCovers then
- -- Fallback 1: Last.fm
+ Just m ->
+ if Set.member m failedCovers then
if Set.member lastfmId failedCovers then
- -- Fallback 2: Discogs
if Set.member discogsId failedCovers then Nothing
- else Just { id: discogsId, url: "/discogs?artist=" <> (fromMaybe "" $ encodeURIComponent artist) <> "&release=" <> (fromMaybe "" $ encodeURIComponent release) }
- else Just { id: lastfmId, url: "/lastfm?artist=" <> (fromMaybe "" $ encodeURIComponent artist) <> "&release=" <> (fromMaybe "" $ encodeURIComponent release) }
- else Just { id: m, url: "https://coverartarchive.org/release/" <> m <> "/front-250" }
- Nothing ->
- -- No MBID, try Last.fm then Discogs
+ else Just { id: discogsId, url: "/discogs-cover?artist=" <> (fromMaybe "" $ encodeURIComponent artist) <> "&release=" <> (fromMaybe "" $ encodeURIComponent release) }
+ else Just { id: lastfmId, url: "/lastfm-cover?artist=" <> (fromMaybe "" $ encodeURIComponent artist) <> "&release=" <> (fromMaybe "" $ encodeURIComponent release) }
+ else Just { id: m, url: "/caa-cover?mbid=" <> m }
+ Nothing ->
if Set.member lastfmId failedCovers then
if Set.member discogsId failedCovers then Nothing
- else Just { id: discogsId, url: "/discogs?artist=" <> (fromMaybe "" $ encodeURIComponent artist) <> "&release=" <> (fromMaybe "" $ encodeURIComponent release) }
- else Just { id: lastfmId, url: "/lastfm?artist=" <> (fromMaybe "" $ encodeURIComponent artist) <> "&release=" <> (fromMaybe "" $ encodeURIComponent release) }
+ else Just { id: discogsId, url: "/discogs-cover?artist=" <> (fromMaybe "" $ encodeURIComponent artist) <> "&release=" <> (fromMaybe "" $ encodeURIComponent release) }
+ else Just { id: lastfmId, url: "/lastfm-cover?artist=" <> (fromMaybe "" $ encodeURIComponent artist) <> "&release=" <> (fromMaybe "" $ encodeURIComponent release) }
in
- HH.li
- [ HP.class_ (H.ClassName "success") ]
- [ HH.div
- [ HP.class_ (H.ClassName "track-info") ]
- [ HH.div
- [ HP.class_ (H.ClassName "track-name") ]
- [ HH.text $ fromMaybe "Unknown Track" track.trackName ]
- , HH.div
- [ HP.class_ (H.ClassName "track-artist") ]
- [ HH.text artist ]
- , HH.div
- [ HP.class_ (H.ClassName "track-time") ]
- [ let
- query = fromMaybe "" $ encodeURIComponent (artist <> " " <> release)
- in
- HH.span_
- [ HH.a
- [ HP.href $ "https://www.discogs.com/search/?q=" <> query <> "&type=release"
- , HP.target "_blank"
- , HP.class_ (H.ClassName "album-link")
+ HH.li
+ [ HP.class_ (H.ClassName "success") ]
+ [ HH.div
+ [ HP.class_ (H.ClassName "track-info") ]
+ [ HH.div
+ [ HP.class_ (H.ClassName "track-name") ]
+ [ HH.text $ fromMaybe "Unknown Track" track.trackName ]
+ , HH.div
+ [ HP.class_ (H.ClassName "track-artist") ]
+ [ HH.text artist ]
+ , HH.div
+ [ HP.class_ (H.ClassName "track-time") ]
+ [ let
+ query = fromMaybe "" $ encodeURIComponent (artist <> " " <> release)
+ in
+ HH.span_
+ [ HH.a
+ [ HP.href $ "https://www.discogs.com/search/?q=" <> query <> "&type=release"
+ , HP.target "_blank"
+ , HP.class_ (H.ClassName "album-link")
+ ]
+ [ HH.text release ]
+ , HH.text $ " • " <> (fromMaybe "unknown time" $ formatTimeAgo currentTime listenedAt)
]
- [ HH.text release ]
- , HH.text $ " • " <> (fromMaybe "unknown time" $ formatTimeAgo currentTime listenedAt)
- ]
- ]
- ]
- , case coverInfo of
- Just { id, url } ->
- HH.img
- [ HP.class_ (H.ClassName "track-cover")
- , HP.src url
- , HP.alt release
- , HE.onError \_ -> ImageError id
- ]
- Nothing -> HH.text ""
- ]
+ ]
+ ]
+ , case coverInfo of
+ Just { id, url } ->
+ HH.img
+ [ HP.class_ (H.ClassName "track-cover")
+ , HP.src url
+ , HP.alt release
+ , HE.onError \_ -> ImageError id
+ ]
+ Nothing -> HH.text ""
+ ]
handleAction = case _ of
Initialize -> do
+ w <- liftEffect window
+ loc <- liftEffect $ location w
+ qs <- liftEffect $ search loc
+ let pageParam = toMaybe $ extractParam "page" qs
+ let initialPage = fromMaybe 1 (pageParam >>= fromString)
+ let initialOffset = max 0 ((initialPage - 1) * 25)
+
+ H.modify_ _ { offset = initialOffset }
+
void $ H.fork $ forever (H.liftAff (delay (Milliseconds 30000.0)) *> handleAction Refresh)
handleAction Refresh
Refresh -> do
+ state <- H.get
H.modify_ _ { loading = true, error = Nothing }
- response <- H.liftAff fetchListens
+ response <- H.liftAff $ fetchListens state.limit state.offset
handleAction (ReceiveResponse response)
ReceiveResponse result -> do
nowInstant <- liftEffect now
let nowMs = unInstant nowInstant
- let nowStr = "Last check: " <> show nowInstant
+ let nowStr = formatRFC3339 nowInstant
case result of
Left err -> H.modify_ _ { loading = false, error = Just err, lastCheck = Just nowStr, currentTime = Just nowMs }
Right listens -> H.modify_ _ { loading = false, listens = listens, lastCheck = Just nowStr, currentTime = Just nowMs }
ImageError mbid -> do
liftEffect $ Console.log $ "Image load failed for: " <> mbid
H.modify_ \state -> state { failedCovers = Set.insert mbid state.failedCovers }
+ NextPage -> do
+ H.modify_ \state -> state { offset = state.offset + state.limit }
+ updateUrl
+ handleAction Refresh
+ PrevPage -> do
+ H.modify_ \state -> state { offset = max 0 (state.offset - state.limit) }
+ updateUrl
+ handleAction Refresh
+
+ updateUrl = do
+ state <- H.get
+ let page = (state.offset / state.limit) + 1
+ liftEffect do
+ w <- window
+ h <- history w
+ pushState (unsafeToForeign {}) (DocumentTitle "") (URL $ "?page=" <> show page) h
- fetchListens :: Aff (Either String (Array Listen))
- fetchListens = do
- res <- AX.get ResponseFormat.json "/proxy"
+ fetchListens :: Int -> Int -> Aff (Either String (Array Listen))
+ fetchListens limit offset = do
+ let url = "/proxy?limit=" <> show limit <> "&offset=" <> show offset
+ res <- AX.get ResponseFormat.json url
case res of
Left err -> pure $ Left $ "Network error: " <> AX.printError err
Right response ->
@@ -196,14 +241,15 @@ component =
let
nowSecs = floor (nowMs / 1000.0)
diff = nowSecs - timestamp
- in Just $
- if diff < 60 then "just now"
- else if diff < 3600 then
- let mins = diff / 60 in show mins <> " minute" <> (if mins > 1 then "s" else "") <> " ago"
- else if diff < 86400 then
- let hours = diff / 3600 in show hours <> " hour" <> (if hours > 1 then "s" else "") <> " ago"
- else
- let days = diff / 86400 in show days <> " day" <> (if days > 1 then "s" else "") <> " ago"
+ in
+ Just $
+ if diff < 60 then "just now"
+ else if diff < 3600 then
+ let mins = diff / 60 in show mins <> " minute" <> (if mins > 1 then "s" else "") <> " ago"
+ else if diff < 86400 then
+ let hours = diff / 3600 in show hours <> " hour" <> (if hours > 1 then "s" else "") <> " ago"
+ else
+ let days = diff / 86400 in show days <> " day" <> (if days > 1 then "s" else "") <> " ago"
main :: Effect Unit
main = HA.runHalogenAff do
@@ -211,3 +257,6 @@ main = HA.runHalogenAff do
case maybeApp of
Nothing -> HA.awaitBody >>= runUI component unit
Just app -> runUI component unit app
+
+foreign import extractParam :: String -> String -> Nullable String
+foreign import formatRFC3339 :: Instant -> String
diff --git a/src/Db.js b/src/Db.js
@@ -0,0 +1,40 @@
+import duckdb from 'duckdb';
+
+export const connectImpl = (path) => (cb) => () => {
+ const db = new duckdb.Database(path, (err) => {
+ if (err) {
+ cb(err)(null)();
+ } else {
+ try {
+ const conn = db.connect();
+ cb(null)(conn)();
+ } catch (e) {
+ cb(e)(null)();
+ }
+ }
+ });
+};
+
+export const runImpl = (conn) => (sql) => (params) => (cb) => () => {
+ conn.run(sql, ...params, (err) => {
+ cb(err)();
+ });
+};
+
+export const allImpl = (conn) => (sql) => (params) => (cb) => () => {
+ conn.all(sql, ...params, (err, rows) => {
+ if (rows) {
+ // DuckDB returns BIGINT as BigInt, which JSON.stringify doesn't support.
+ // We convert them to Numbers here.
+ for (let i = 0; i < rows.length; i++) {
+ const row = rows[i];
+ for (const key in row) {
+ if (typeof row[key] === 'bigint') {
+ row[key] = Number(row[key]);
+ }
+ }
+ }
+ }
+ cb(err)(rows)();
+ });
+};
diff --git a/src/Db.purs b/src/Db.purs
@@ -0,0 +1,110 @@
+module Db where
+
+import Prelude
+
+import Data.Argonaut.Core (Json, toObject, toString, toArray)
+import Data.Either (Either(..))
+import Data.Maybe (Maybe(..), fromMaybe)
+import Effect (Effect)
+import Effect.Class (liftEffect)
+import Effect.Aff (Aff, makeAff, nonCanceler)
+import Effect.Exception (Error, error)
+import Foreign (Foreign)
+import Unsafe.Coerce (unsafeCoerce)
+import Types (Listen(..), TrackMetadata(..), MbidMapping(..))
+import Data.Traversable (traverse)
+import Foreign.Object as Object
+import Data.Nullable (Nullable, toMaybe)
+
+foreign import data Connection :: Type
+
+foreign import connectImpl :: String -> (Nullable Error -> Nullable Connection -> Effect Unit) -> Effect Unit
+foreign import runImpl :: Connection -> String -> Array Foreign -> (Nullable Error -> Effect Unit) -> Effect Unit
+foreign import allImpl :: Connection -> String -> Array Foreign -> (Nullable Error -> Nullable (Array Json) -> Effect Unit) -> Effect Unit
+
+connect :: String -> Aff Connection
+connect path = makeAff \cb -> do
+ connectImpl path \err conn ->
+ case toMaybe err of
+ Just e -> cb (Left e)
+ Nothing -> case toMaybe conn of
+ Just c -> cb (Right c)
+ Nothing -> cb (Left $ error "Failed to create connection")
+ pure nonCanceler
+
+run :: Connection -> String -> Array Foreign -> Aff Unit
+run conn sql params = makeAff \cb -> do
+ runImpl conn sql params \err ->
+ case toMaybe err of
+ Just e -> cb (Left e)
+ Nothing -> cb (Right unit)
+ pure nonCanceler
+
+queryAll :: Connection -> String -> Array Foreign -> Aff (Array Json)
+queryAll conn sql params = makeAff \cb -> do
+ allImpl conn sql params \err rows ->
+ case toMaybe err of
+ Just e -> cb (Left e)
+ Nothing -> cb (Right (fromMaybe [] (toMaybe rows)))
+ pure nonCanceler
+
+initDb :: Connection -> Aff Unit
+initDb conn = do
+ run conn "CREATE TABLE IF NOT EXISTS scrobbles (listened_at BIGINT PRIMARY KEY, track_name VARCHAR, artist_name VARCHAR, release_name VARCHAR, release_mbid VARCHAR, caa_release_mbid VARCHAR)" []
+
+checkExists :: Connection -> Int -> Aff Boolean
+checkExists conn ts = do
+ rows <- queryAll conn "SELECT 1 FROM scrobbles WHERE listened_at = ?" [ unsafeCoerce ts ]
+ pure $ fromMaybe false $ do
+ arr <- Just rows
+ case arr of
+ [] -> Just false
+ _ -> Just true
+
+upsertScrobble :: Connection -> Listen -> Aff Unit
+upsertScrobble conn (Listen { listenedAt, trackMetadata: TrackMetadata track }) = do
+ case listenedAt of
+ Nothing -> pure unit
+ Just ts -> do
+ let
+ mbid = fromMaybe (MbidMapping { releaseMbid: Nothing, caaReleaseMbid: Nothing }) track.mbidMapping
+ MbidMapping m = mbid
+ params =
+ [ unsafeCoerce ts
+ , unsafeCoerce (fromMaybe "" track.trackName)
+ , unsafeCoerce (fromMaybe "" track.artistName)
+ , unsafeCoerce (fromMaybe "" track.releaseName)
+ , unsafeCoerce (fromMaybe "" m.releaseMbid)
+ , unsafeCoerce (fromMaybe "" m.caaReleaseMbid)
+ ]
+ _ <- run conn "INSERT INTO scrobbles SELECT * FROM (SELECT ? as listened_at, ? as track_name, ? as artist_name, ? as release_name, ? as release_mbid, ? as caa_release_mbid) t WHERE NOT EXISTS (SELECT 1 FROM scrobbles WHERE listened_at = t.listened_at)" params
+ pure unit
+
+getScrobbles :: Connection -> Int -> Int -> Aff (Array Listen)
+getScrobbles conn limit offset = do
+ rows <- queryAll conn "SELECT listened_at, track_name, artist_name, release_name, release_mbid, caa_release_mbid FROM scrobbles ORDER BY listened_at DESC LIMIT ? OFFSET ?"
+ [ unsafeCoerce limit, unsafeCoerce offset ]
+ pure $ fromMaybe [] $ traverse rowToListen rows
+
+rowToListen :: Json -> Maybe Listen
+rowToListen json = do
+ obj <- toObject json
+ listenedAt <- Object.lookup "listened_at" obj >>= (unsafeCoerce >>> Just)
+ trackName <- Object.lookup "track_name" obj >>= toString
+ artistName <- Object.lookup "artist_name" obj >>= toString
+ releaseName <- Object.lookup "release_name" obj >>= toString
+ releaseMbid <- Object.lookup "release_mbid" obj >>= toString
+ caaReleaseMbid <- Object.lookup "caa_release_mbid" obj >>= toString
+
+ pure $ Listen
+ { listenedAt: Just listenedAt
+ , trackMetadata: TrackMetadata
+ { trackName: Just trackName
+ , artistName: Just artistName
+ , releaseName: Just releaseName
+ , mbidMapping: Just $ MbidMapping
+ { releaseMbid: if releaseMbid == "" then Nothing else Just releaseMbid
+ , caaReleaseMbid: if caaReleaseMbid == "" then Nothing else Just caaReleaseMbid
+ }
+ }
+ }
diff --git a/src/Main.js b/src/Main.js
@@ -0,0 +1,21 @@
+import { config } from 'dotenv';
+
+export const dotenvConfig = () => {
+ config();
+};
+
+export const getQueryParam = (name) => (url) => () => {
+ return url.searchParams.get(name);
+};
+
+export const split = (sep) => (str) => {
+ return str.split(sep);
+};
+
+export const writeBuffer = (stream) => (buffer) => () => {
+ stream.write(Buffer.from(buffer));
+};
+
+export const sanitizeKey = (str) => {
+ return str.replace(/[^a-z0-9]/gi, '_').replace(/_{2,}/g, '_');
+};
diff --git a/src/Main.purs b/src/Main.purs
@@ -15,26 +15,34 @@ 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, writeString, pipe)
+import Node.Stream (Writable, end, writeString)
import Node.Stream.Aff (readableToStringUtf8)
import Node.Encoding (Encoding(UTF8))
import Node.Net.Server (listenTcp, listeningH)
import Data.Either (Either(..))
import Effect.Exception as Exception
-import Effect.Aff (Aff, launchAff_, makeAff, nonCanceler, try)
+import Effect.Aff (Aff, launchAff_, makeAff, nonCanceler, try, delay, forkAff)
+import Foreign (Foreign)
import Unsafe.Coerce (unsafeCoerce)
import Node.FS.Aff as FSA
import Node.Process (getEnv)
-import Fetch (fetch, Method(GET))
+import Fetch (fetch, Method(GET), lookup)
import Fetch.Argonaut.Json (fromJson)
import Data.Maybe (Maybe(..), fromMaybe)
import JSURI (encodeURIComponent)
import Node.URL (URL, new', pathname)
-import Affjax.RequestHeader (RequestHeader(..))
import Foreign.Object as Object
-import Data.Argonaut.Core (toObject, toArray, toString)
-import Data.Array ((!!))
+import Data.Argonaut (decodeJson, encodeJson, parseJson)
+import Data.Argonaut.Core (toObject, toArray, toString, stringify)
+import Data.Array ((!!), length, uncons)
import Data.Nullable (Nullable, toMaybe)
+import Db (Connection, connect, initDb, upsertScrobble, getScrobbles, checkExists, run)
+import Types (Listen(..), ListenBrainzResponse(..), Payload(..))
+import Control.Monad.Rec.Class (forever)
+import Data.Time.Duration (Milliseconds(..))
+import Data.Int (fromString)
+import Data.Foldable (traverse_)
+import S3 (existsInS3, uploadToS3, getS3Url)
-- Types
type Request = IncomingMessage IMServer
@@ -43,10 +51,11 @@ type Response = ServerResponse
listenBrainzUrl :: String
listenBrainzUrl = "https://api.listenbrainz.org/1/user/mtmn/listens"
-fetchListenBrainzData :: Aff String
-fetchListenBrainzData = makeAff \callback -> do
- Console.log $ "Fetching from ListenBrainz: " <> listenBrainzUrl
- req <- HTTPS.get listenBrainzUrl
+fetchListenBrainzData :: Int -> Aff String
+fetchListenBrainzData count = makeAff \callback -> do
+ let url = listenBrainzUrl <> "?count=" <> show count
+ Console.log $ "Fetching from ListenBrainz: " <> url
+ req <- HTTPS.get url
req # on_ Client.responseH \res -> do
let sc = IM.statusCode res
@@ -65,16 +74,44 @@ fetchListenBrainzData = makeAff \callback -> do
pure nonCanceler
-handleApiRequest :: Aff String
-handleApiRequest = do
- result <- try fetchListenBrainzData
- case result of
- Right responseData -> do
- liftEffect $ Console.log $ "Successfully fetched bytes"
- pure responseData
- Left error -> do
- liftEffect $ Console.log $ "Error in handleApiRequest: " <> Exception.message error
- pure "{\"error\": \"ListenBrainz fetch failed\"}"
+syncData :: Connection -> Aff Unit
+syncData conn = do
+ env <- liftEffect getEnv
+ let shouldInitialSync = Object.lookup "INITIAL_SYNC" env == Just "true"
+
+ if shouldInitialSync then do
+ liftEffect $ Console.log "Performing initial sync of 10000 tracks"
+ void $ performSync 10000
+ else
+ liftEffect $ Console.log "Initial sync skipped (INITIAL_SYNC != true)"
+
+ pure unit
+ where
+ performSync count = do
+ result <- try $ fetchListenBrainzData count
+ case result of
+ Right body -> do
+ case parseJson body >>= decodeJson of
+ Left err -> liftEffect $ Console.log $ "Sync parse error: " <> show err
+ Right (ListenBrainzResponse { payload: Payload { listens } }) -> do
+ liftEffect $ Console.log $ "Processing " <> show (length listens) <> " scrobbles"
+ run conn "BEGIN TRANSACTION" []
+ newCount <- syncRecursive 0 listens
+ run conn "COMMIT" []
+ liftEffect $ Console.log $ "Sync complete. Added " <> show newCount <> " new scrobbles."
+ Left err -> liftEffect $ Console.log $ "Sync fetch error: " <> Exception.message err
+
+ syncRecursive acc listens = case uncons listens of
+ Nothing -> pure acc
+ Just { head: l@(Listen { listenedAt: Just ts }), tail } -> do
+ exists <- checkExists conn ts
+ if exists then do
+ liftEffect $ Console.log $ "Hit existing record at " <> show ts <> ". Stopping sync."
+ pure acc
+ else do
+ upsertScrobble conn l
+ syncRecursive (acc + 1) tail
+ Just { head: _, tail } -> syncRecursive acc tail
indexHtml :: String
indexHtml =
@@ -240,6 +277,40 @@ indexHtml =
50% { opacity: 0.3; }
100% { opacity: 1; }
}
+
+ .pagination {
+ display: flex;
+ justify-content: center;
+ gap: 20px;
+ margin-top: 20px;
+ }
+
+ .page-btn {
+ background: #521e40;
+ border: 1px solid #50447f;
+ color: #ffffff;
+ padding: 8px 16px;
+ border-radius: 4px;
+ cursor: pointer;
+ font-family: inherit;
+ box-shadow: 2px 2px 0px #50447f;
+ }
+
+ .page-btn:hover {
+ background: #50447f;
+ }
+
+ .page-btn:disabled {
+ opacity: 0.5;
+ cursor: not-allowed;
+ }
+
+ .page-indicator {
+ display: flex;
+ align-items: center;
+ font-size: 14px;
+ color: #9fbfe7;
+ }
</style>
</head>
<body>
@@ -249,8 +320,8 @@ indexHtml =
</html>"""
-- Request handler
-handleRequest :: Request -> Response -> Effect Unit
-handleRequest req res = do
+handleRequest :: Connection -> Request -> Response -> Effect Unit
+handleRequest db req res = do
let rawUrl = IM.url req
url <- new' rawUrl "http://localhost"
path <- pathname url
@@ -258,7 +329,8 @@ handleRequest req res = do
case path of
"/" -> serveIndex res
- "/proxy" -> serveProxy res
+ "/proxy" -> serveProxy db url res
+ "/caa-cover" -> serveCaaCover url res
"/discogs-cover" -> serveDiscogsCover url res
"/lastfm-cover" -> serveLastfmCover url res
"/client.js" -> serveClientJs res
@@ -289,6 +361,33 @@ serveClientJs res = do
Left _ -> serveNotFound res
foreign import getQueryParam :: String -> URL -> Effect (Nullable String)
+foreign import writeBuffer :: forall r. Writable r -> Foreign -> Effect Unit
+foreign import sanitizeKey :: String -> String
+
+serveCaaCover :: URL -> Response -> Effect Unit
+serveCaaCover url res = do
+ launchAff_ do
+ mbidMaybe <- liftEffect $ getQueryParam "mbid" url
+ case toMaybe mbidMaybe of
+ Nothing -> liftEffect $ serveNotFound res
+ Just mbid -> do
+ let s3Key = "covers/caa/" <> mbid <> ".jpg"
+ cachedResult <- try $ existsInS3 s3Key
+ let
+ cached = case cachedResult of
+ Right b -> b
+ Left _ -> false
+
+ if cached then do
+ liftEffect $ Console.log $ "Serving CAA cover from S3: " <> s3Key
+ liftEffect $ do
+ setStatusCode 302 res
+ setHeader "Location" (getS3Url s3Key) (toOutgoingMessage res)
+ end (toWriteable (toOutgoingMessage res))
+ else do
+ let caaUrl = "https://coverartarchive.org/release/" <> mbid <> "/front-250"
+ liftEffect $ Console.log $ "Fetching CAA cover: " <> mbid
+ proxyAndCacheImage caaUrl s3Key res
serveLastfmCover :: URL -> Response -> Effect Unit
serveLastfmCover url res = do
@@ -298,113 +397,165 @@ serveLastfmCover url res = do
let artistStr = fromMaybe "" (toMaybe artistMaybe)
let releaseStr = fromMaybe "" (toMaybe releaseMaybe)
- env <- liftEffect getEnv
- let apiKey = Object.lookup "LASTFM_API_KEY" env
- case apiKey of
- Nothing -> liftEffect $ serveNotFound res
- Just k -> do
- let searchUrl = "https://ws.audioscrobbler.com/2.0/?method=album.getinfo&api_key=" <> k <> "&artist=" <> (fromMaybe "" $ encodeURIComponent artistStr) <> "&album=" <> (fromMaybe "" $ encodeURIComponent releaseStr) <> "&format=json"
- liftEffect $ Console.log $ "Last.fm search: " <> artistStr <> " - " <> releaseStr
-
- result <- try $ fetch searchUrl { method: GET }
- case result of
- Right fetchRes -> do
- json <- fromJson fetchRes.json
- let coverUrl = do
+ let safeArtist = sanitizeKey artistStr
+ let safeRelease = sanitizeKey releaseStr
+ let s3Key = "covers/lastfm/" <> safeArtist <> "-" <> safeRelease <> ".jpg"
+
+ cachedResult <- try $ existsInS3 s3Key
+ let
+ cached = case cachedResult of
+ Right b -> b
+ Left _ -> false
+
+ if cached then do
+ liftEffect $ Console.log $ "Serving Last.fm cover from S3: " <> s3Key
+ liftEffect $ do
+ setStatusCode 302 res
+ setHeader "Location" (getS3Url s3Key) (toOutgoingMessage res)
+ end (toWriteable (toOutgoingMessage res))
+ else do
+ env <- liftEffect getEnv
+ let apiKey = Object.lookup "LASTFM_API_KEY" env
+ case apiKey of
+ Nothing -> liftEffect $ serveNotFound res
+ Just k -> do
+ let searchUrl = "https://ws.audioscrobbler.com/2.0/?method=album.getinfo&api_key=" <> k <> "&artist=" <> (fromMaybe "" $ encodeURIComponent artistStr) <> "&album=" <> (fromMaybe "" $ encodeURIComponent releaseStr) <> "&format=json"
+ liftEffect $ Console.log $ "Last.fm search: " <> artistStr <> " - " <> releaseStr
+
+ result <- try $ fetch searchUrl { method: GET }
+ case result of
+ Right fetchRes -> do
+ json <- fromJson fetchRes.json
+ let
+ coverUrl = do
obj <- toObject json
album <- Object.lookup "album" obj >>= toObject
images <- Object.lookup "image" album >>= toArray
- -- Try to get the large image (index 2 or 3)
imageObj <- images !! 2 >>= toObject
u <- Object.lookup "#text" imageObj >>= toString
if u == "" then Nothing else Just u
-
- case coverUrl of
- Just urlStr -> do
- liftEffect $ Console.log $ "Found Last.fm cover: " <> urlStr
- proxyImage urlStr res
- Nothing -> do
- liftEffect $ Console.log $ "No Last.fm cover found for: " <> artistStr <> " - " <> releaseStr
- liftEffect $ serveNotFound res
- Left err -> do
- liftEffect $ Console.log $ "Last.fm API error: " <> Exception.message err
- liftEffect $ serveNotFound res
+
+ case coverUrl of
+ Just urlStr -> do
+ liftEffect $ Console.log $ "Found Last.fm cover: " <> urlStr
+ proxyAndCacheImage urlStr s3Key res
+ Nothing -> do
+ liftEffect $ Console.log $ "No Last.fm cover found for: " <> artistStr <> " - " <> releaseStr
+ liftEffect $ serveNotFound res
+ Left err -> do
+ liftEffect $ Console.log $ "Last.fm API error: " <> Exception.message err
+ liftEffect $ serveNotFound res
serveDiscogsCover :: URL -> Response -> Effect Unit
serveDiscogsCover url res = do
launchAff_ do
artistMaybe <- liftEffect $ getQueryParam "artist" url
releaseMaybe <- liftEffect $ getQueryParam "release" url
-
let artistStr = fromMaybe "" (toMaybe artistMaybe)
let releaseStr = fromMaybe "" (toMaybe releaseMaybe)
- env <- liftEffect getEnv
- let token = Object.lookup "DISCOGS_TOKEN" env
- case token of
- Nothing -> do
- liftEffect $ Console.log "DISCOGS_TOKEN not found in env"
- liftEffect $ serveNotFound res
- Just t -> do
- let queryStr = artistStr <> " " <> releaseStr
- let searchUrl = "https://api.discogs.com/database/search?q=" <> (fromMaybe "" $ encodeURIComponent queryStr) <> "&type=release&per_page=1&token=" <> t
- liftEffect $ Console.log $ "Discogs search (broad): " <> queryStr
-
- result <- try $ fetch searchUrl { method: GET, headers: { "User-Agent": "ScrobblerPureScript/1.0" } }
- case result of
- Right fetchRes -> do
- json <- fromJson fetchRes.json
- let coverUrl = do
+ let safeArtist = sanitizeKey artistStr
+ let safeRelease = sanitizeKey releaseStr
+ let s3Key = "covers/discogs/" <> safeArtist <> "-" <> safeRelease <> ".jpg"
+
+ cachedResult <- try $ existsInS3 s3Key
+ let
+ cached = case cachedResult of
+ Right b -> b
+ Left _ -> false
+
+ if cached then do
+ liftEffect $ Console.log $ "Serving Discogs cover from S3: " <> s3Key
+ liftEffect $ do
+ setStatusCode 302 res
+ setHeader "Location" (getS3Url s3Key) (toOutgoingMessage res)
+ end (toWriteable (toOutgoingMessage res))
+ else do
+ env <- liftEffect getEnv
+ let token = Object.lookup "DISCOGS_TOKEN" env
+ case token of
+ Nothing -> do
+ liftEffect $ Console.log "DISCOGS_TOKEN not found in env"
+ liftEffect $ serveNotFound res
+ Just t -> do
+ let queryStr = artistStr <> " " <> releaseStr
+ let searchUrl = "https://api.discogs.com/database/search?q=" <> (fromMaybe "" $ encodeURIComponent queryStr) <> "&type=release&per_page=1&token=" <> t
+ liftEffect $ Console.log $ "Discogs search (broad): " <> queryStr
+
+ result <- try $ fetch searchUrl { method: GET, headers: { "User-Agent": "ScrobblerPureScript/1.0" } }
+ case result of
+ Right fetchRes -> do
+ json <- fromJson fetchRes.json
+ let
+ coverUrl = do
obj <- toObject json
results <- Object.lookup "results" obj >>= toArray
firstResult <- results !! 0 >>= toObject
cover <- Object.lookup "cover_image" firstResult >>= toString
pure cover
-
- case coverUrl of
- Just urlStr -> do
- liftEffect $ Console.log $ "Found Discogs cover: " <> urlStr
- proxyImage urlStr res
- Nothing -> do
- liftEffect $ Console.log $ "No Discogs cover found for: " <> queryStr
- liftEffect $ serveNotFound res
- Left err -> do
- liftEffect $ Console.log $ "Discogs API error: " <> Exception.message err
- liftEffect $ serveNotFound res
-
-proxyImage :: String -> Response -> Aff Unit
-proxyImage urlStr res = liftEffect $ do
- imgReq <- HTTPS.get urlStr
- imgReq # on_ Client.responseH \imgRes -> do
- let imgSc = IM.statusCode imgRes
- setStatusCode imgSc res
- setHeader "Content-Type" (fromMaybe "image/jpeg" $ Object.lookup "content-type" (IM.headers imgRes)) (toOutgoingMessage res)
- setHeader "Cache-Control" "public, max-age=86400" (toOutgoingMessage res)
-
- let reader = IM.toReadable imgRes
- let writer = toWriteable (toOutgoingMessage res)
- void $ pipe reader writer
-
- let errorH = EventHandle "error" mkEffectFn1
- on_ errorH (\err -> do
- Console.log $ "Image proxy error: " <> Exception.message err
- serveNotFound res
- ) (unsafeCoerce imgReq)
-serveProxy :: Response -> Effect Unit
-serveProxy res = do
+ case coverUrl of
+ Just urlStr -> do
+ liftEffect $ Console.log $ "Found Discogs cover: " <> urlStr
+ proxyAndCacheImage urlStr s3Key res
+ Nothing -> do
+ liftEffect $ Console.log $ "No Discogs cover found for: " <> queryStr
+ liftEffect $ serveNotFound res
+ Left err -> do
+ liftEffect $ Console.log $ "Discogs API error: " <> Exception.message err
+ liftEffect $ serveNotFound res
+
+proxyAndCacheImage :: String -> String -> Response -> Aff Unit
+proxyAndCacheImage urlStr s3Key res = do
+ liftEffect $ Console.log $ "Proxying and caching image: " <> urlStr
+ makeAff \cb -> do
+ launchAff_ do
+ fetchResult <- try $ fetch urlStr { method: GET }
+ case fetchResult of
+ Right fr -> do
+ let contentType = fromMaybe "image/jpeg" $ lookup "content-type" fr.headers
+ buf <- fr.arrayBuffer
+ liftEffect $ do
+ setStatusCode fr.status res
+ setHeader "Content-Type" contentType (toOutgoingMessage res)
+ setHeader "Cache-Control" "public, max-age=86400" (toOutgoingMessage res)
+ let writer = toWriteable (toOutgoingMessage res)
+ writeBuffer writer (unsafeCoerce buf)
+ end writer
+
+ -- Cache to S3
+ uploadResult <- try $ uploadToS3 s3Key (unsafeCoerce buf) contentType
+ case uploadResult of
+ Right _ -> liftEffect $ Console.log $ "Cached to S3: " <> s3Key
+ Left err -> liftEffect $ Console.log $ "S3 upload failed: " <> Exception.message err
+ liftEffect $ cb (Right unit)
+ Left err -> do
+ liftEffect $ Console.log $ "Failed to fetch image: " <> Exception.message err
+ liftEffect $ serveNotFound res
+ liftEffect $ cb (Right unit)
+ pure nonCanceler
+
+serveProxy :: Connection -> URL -> Response -> Effect Unit
+serveProxy db url res = do
setHeader "Content-Type" "application/json" (toOutgoingMessage res)
setHeader "Access-Control-Allow-Origin" "*" (toOutgoingMessage res)
setHeader "Access-Control-Allow-Methods" "GET, POST, OPTIONS" (toOutgoingMessage res)
setHeader "Access-Control-Allow-Headers" "*" (toOutgoingMessage res)
- -- Launch the Aff action to fetch data from ListenBrainz
launchAff_ do
- body <- handleApiRequest
+ limitStr <- liftEffect $ getQueryParam "limit" url
+ offsetStr <- liftEffect $ getQueryParam "offset" url
+
+ let limit = fromMaybe 25 (toMaybe limitStr >>= fromString)
+ let offset = fromMaybe 0 (toMaybe offsetStr >>= fromString)
+
+ listens <- getScrobbles db limit offset
+ let responseBody = stringify $ encodeJson { payload: { listens: listens } }
+
liftEffect $ do
setStatusCode 200 res
let w = toWriteable (toOutgoingMessage res)
- void $ writeString w UTF8 body
+ void $ writeString w UTF8 responseBody
end w
serveFavicon :: Response -> Effect Unit
@@ -424,15 +575,20 @@ serveNotFound res = do
end w
startServer :: Int -> Effect Unit
-startServer port = do
- server <- createServer
- server # on_ Server.requestH handleRequest
- let netServer = Server.toNetServer server
+startServer port = launchAff_ do
+ conn <- connect "scorpus.db"
+ initDb conn
+ void $ forkAff $ syncData conn
- netServer # on_ listeningH do
- Console.log $ "Server is running on port " <> show port
+ liftEffect $ do
+ server <- createServer
+ server # on_ Server.requestH (handleRequest conn)
+ let netServer = Server.toNetServer server
- listenTcp netServer { host: "127.0.0.1", port, backlog: 128 }
+ netServer # on_ listeningH do
+ Console.log $ "Server is running on port " <> show port
+
+ listenTcp netServer { host: "127.0.0.1", port, backlog: 128 }
foreign import dotenvConfig :: Effect Unit
@@ -440,3 +596,5 @@ main :: Effect Unit
main = do
dotenvConfig
startServer 8000
+
+foreign import split :: String -> String -> Array String
diff --git a/src/S3.js b/src/S3.js
@@ -0,0 +1,62 @@
+import { S3Client, PutObjectCommand, HeadObjectCommand } from "@aws-sdk/client-s3";
+
+const getClient = () => new S3Client({
+ region: process.env.S3_REGION || "us-east-1",
+ endpoint: process.env.AWS_ENDPOINT_URL,
+ forcePathStyle: process.env.AWS_S3_ADDRESSING_STYLE === "path",
+ credentials: {
+ accessKeyId: process.env.AWS_ACCESS_KEY_ID,
+ secretAccessKey: process.env.AWS_SECRET_ACCESS_KEY
+ }
+});
+
+export const uploadToS3Impl = (key) => (body) => (contentType) => (cb) => () => {
+ const client = getClient();
+ const command = new PutObjectCommand({
+ Bucket: process.env.S3_BUCKET,
+ Key: key,
+ Body: body,
+ ContentType: contentType
+ });
+
+ console.log(`S3: Uploading ${key} to bucket ${process.env.S3_BUCKET} at ${process.env.AWS_ENDPOINT_URL}`);
+
+ client.send(command)
+ .then(() => {
+ console.log(`S3: Successfully uploaded ${key}`);
+ cb(null)();
+ })
+ .catch((err) => {
+ console.error(`S3: Upload failed for ${key}`, err);
+ cb(err)();
+ });
+};
+
+export const existsInS3Impl = (key) => (cb) => () => {
+ const client = getClient();
+ const command = new HeadObjectCommand({
+ Bucket: process.env.S3_BUCKET,
+ Key: key
+ });
+
+ client.send(command)
+ .then(() => cb(true)())
+ .catch((err) => {
+ if (err.name === "NotFound" || err.$metadata?.httpStatusCode === 404) {
+ cb(false)();
+ } else {
+ console.error(`S3: exists check failed for ${key}`, err);
+ cb(false)();
+ }
+ });
+};
+
+export const getS3UrlImpl = (key) => {
+ const endpoint = process.env.AWS_ENDPOINT_URL;
+ const bucket = process.env.S3_BUCKET;
+ if (process.env.AWS_S3_ADDRESSING_STYLE === "path") {
+ return `${endpoint}/${bucket}/${key}`;
+ } else {
+ return `${endpoint.replace("://", `://${bucket}.`)}/${key}`;
+ }
+};
diff --git a/src/S3.purs b/src/S3.purs
@@ -0,0 +1,31 @@
+module S3 where
+
+import Prelude
+
+import Data.Either (Either(..))
+import Data.Maybe (Maybe(..))
+import Effect (Effect)
+import Effect.Aff (Aff, makeAff, nonCanceler)
+import Effect.Exception (Error)
+import Node.Buffer (Buffer)
+import Data.Nullable (Nullable, toMaybe)
+
+foreign import uploadToS3Impl :: String -> Buffer -> String -> (Nullable Error -> Effect Unit) -> Effect Unit
+foreign import existsInS3Impl :: String -> (Boolean -> Effect Unit) -> Effect Unit
+foreign import getS3UrlImpl :: String -> String
+
+uploadToS3 :: String -> Buffer -> String -> Aff Unit
+uploadToS3 key body contentType = makeAff \cb -> do
+ uploadToS3Impl key body contentType \err ->
+ case toMaybe err of
+ Just e -> cb (Left e)
+ Nothing -> cb (Right unit)
+ pure nonCanceler
+
+existsInS3 :: String -> Aff Boolean
+existsInS3 key = makeAff \cb -> do
+ existsInS3Impl key \exists -> cb (Right exists)
+ pure nonCanceler
+
+getS3Url :: String -> String
+getS3Url = getS3UrlImpl
diff --git a/src/Types.purs b/src/Types.purs
@@ -2,7 +2,8 @@ module Types where
import Prelude
-import Data.Argonaut (class DecodeJson, decodeJson, (.:), (.:?))
+import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, encodeJson, (.:), (.:?), (:=), (~>))
+import Data.Argonaut.Core (jsonEmptyObject)
import Data.Maybe (Maybe)
import Data.Generic.Rep (class Generic)
@@ -19,6 +20,11 @@ instance DecodeJson ListenBrainzResponse where
payload <- obj .: "payload"
pure $ ListenBrainzResponse { payload }
+instance EncodeJson ListenBrainzResponse where
+ encodeJson (ListenBrainzResponse { payload }) =
+ "payload" := encodeJson payload
+ ~> jsonEmptyObject
+
newtype Payload = Payload
{ listens :: Array Listen
}
@@ -32,6 +38,11 @@ instance DecodeJson Payload where
listens <- obj .: "listens"
pure $ Payload { listens }
+instance EncodeJson Payload where
+ encodeJson (Payload { listens }) =
+ "listens" := encodeJson listens
+ ~> jsonEmptyObject
+
newtype Listen = Listen
{ trackMetadata :: TrackMetadata
, listenedAt :: Maybe Int
@@ -47,6 +58,12 @@ instance DecodeJson Listen where
listenedAt <- obj .:? "listened_at"
pure $ Listen { trackMetadata, listenedAt }
+instance EncodeJson Listen where
+ encodeJson (Listen { trackMetadata, listenedAt }) =
+ "track_metadata" := encodeJson trackMetadata
+ ~> "listened_at" := encodeJson listenedAt
+ ~> jsonEmptyObject
+
newtype TrackMetadata = TrackMetadata
{ trackName :: Maybe String
, artistName :: Maybe String
@@ -66,6 +83,14 @@ instance DecodeJson TrackMetadata where
mbidMapping <- obj .:? "mbid_mapping"
pure $ TrackMetadata { trackName, artistName, releaseName, mbidMapping }
+instance EncodeJson TrackMetadata where
+ encodeJson (TrackMetadata { trackName, artistName, releaseName, mbidMapping }) =
+ "track_name" := encodeJson trackName
+ ~> "artist_name" := encodeJson artistName
+ ~> "release_name" := encodeJson releaseName
+ ~> "mbid_mapping" := encodeJson mbidMapping
+ ~> jsonEmptyObject
+
newtype MbidMapping = MbidMapping
{ releaseMbid :: Maybe String
, caaReleaseMbid :: Maybe String
@@ -80,3 +105,9 @@ instance DecodeJson MbidMapping where
releaseMbid <- obj .:? "release_mbid"
caaReleaseMbid <- obj .:? "caa_release_mbid"
pure $ MbidMapping { releaseMbid, caaReleaseMbid }
+
+instance EncodeJson MbidMapping where
+ encodeJson (MbidMapping { releaseMbid, caaReleaseMbid }) =
+ "release_mbid" := encodeJson releaseMbid
+ ~> "caa_release_mbid" := encodeJson caaReleaseMbid
+ ~> jsonEmptyObject
