commit feafab2a8a43f51acf1f85573800a1a8b6d94c15
parent b59bc2ffe60e1fa8bd797209af5dd3ebcafd74f7
Author: mtmn <miro@haravara.org>
Date: Thu, 23 Apr 2026 14:29:59 +0200
feat: add listenbrainz-like endpoint
Diffstat:
7 files changed, 220 insertions(+), 18 deletions(-)
diff --git a/package-lock.json b/package-lock.json
@@ -12,7 +12,8 @@
"dotenv": "^17.4.1",
"duckdb": "^1.4.4",
"prom-client": "^15.1.3",
- "sharp": "^0.34.5"
+ "sharp": "^0.34.5",
+ "uuid": "^14.0.0"
},
"devDependencies": {
"elm": "^0.19.1",
@@ -6517,6 +6518,19 @@
"integrity": "sha512-EPD5q1uXyFxJpCrLnCc1nHnq3gOa6DZBocAIiI2TaSCA7VCJ1UJDMagCzIkXNsUYfD1daK//LTEQ8xiIbrHtcw==",
"license": "MIT"
},
+ "node_modules/uuid": {
+ "version": "14.0.0",
+ "resolved": "https://registry.npmjs.org/uuid/-/uuid-14.0.0.tgz",
+ "integrity": "sha512-Qo+uWgilfSmAhXCMav1uYFynlQO7fMFiMVZsQqZRMIXp0O7rR7qjkj+cPvBHLgBqi960QCoo/PH2/6ZtVqKvrg==",
+ "funding": [
+ "https://github.com/sponsors/broofa",
+ "https://github.com/sponsors/ctavan"
+ ],
+ "license": "MIT",
+ "bin": {
+ "uuid": "dist-node/bin/uuid"
+ }
+ },
"node_modules/verror": {
"version": "1.10.0",
"resolved": "https://registry.npmjs.org/verror/-/verror-1.10.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 --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",
+ "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 --external:uuid && 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 --external:uuid && 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"
},
@@ -26,6 +26,7 @@
"dotenv": "^17.4.1",
"duckdb": "^1.4.4",
"prom-client": "^15.1.3",
- "sharp": "^0.34.5"
+ "sharp": "^0.34.5",
+ "uuid": "^14.0.0"
}
}
diff --git a/spago.lock b/spago.lock
@@ -35,9 +35,11 @@
"node-url",
"now",
"prelude",
+ "random",
"strings",
"tailrec",
"unsafe-coerce",
+ "uuid",
"web-url"
]
},
@@ -2123,6 +2125,16 @@
"integrity": "sha256-0L1QsaY20OILjfU5TV72d3U/tSjhmL9hJ32WMp857Lk=",
"dependencies": []
},
+ "uuid": {
+ "type": "registry",
+ "version": "9.0.0",
+ "integrity": "sha256-aM/9+7xlHs5UDdtRfoEQosPpYOruwowa3sezIodJ3vk=",
+ "dependencies": [
+ "effect",
+ "maybe",
+ "prelude"
+ ]
+ },
"web-events": {
"type": "registry",
"version": "4.0.0",
diff --git a/spago.yaml b/spago.yaml
@@ -31,9 +31,11 @@ package:
- node-url
- now
- prelude
+ - random
- strings
- tailrec
- unsafe-coerce
+ - uuid
- web-url
test:
main: Test.Main
diff --git a/src/Db.purs b/src/Db.purs
@@ -33,6 +33,7 @@ import Config (S3Config)
import S3 as S3
import Log as Log
import Metrics as Metrics
+import Data.UUID (genUUID, toString) as UUID
foreign import data Connection :: Type
@@ -146,6 +147,18 @@ queryAll conn sql params = makeAff \cb -> do
initDb :: Connection -> Aff Unit
initDb conn = do
run conn "CREATE TABLE IF NOT EXISTS scrobbles (listened_at BIGINT PRIMARY KEY, track_name VARCHAR, artist_name VARCHAR, release_name VARCHAR, release_mbid VARCHAR, caa_release_mbid VARCHAR)" []
+ run conn "CREATE TABLE IF NOT EXISTS api_tokens (slug VARCHAR PRIMARY KEY, token VARCHAR UNIQUE)" []
+
+getOrCreateToken :: Connection -> String -> Aff String
+getOrCreateToken conn slug = do
+ rows <- queryAll conn "SELECT token FROM api_tokens WHERE slug = ?" [ unsafeCoerce slug ]
+ case rows !! 0 >>= toObject >>= Object.lookup "token" >>= toString of
+ Just token ->
+ pure token
+ Nothing -> do
+ token <- liftEffect $ map UUID.toString UUID.genUUID
+ run conn "INSERT INTO api_tokens (slug, token) VALUES (?, ?)" [ unsafeCoerce slug, unsafeCoerce token ]
+ pure token
checkExists :: Connection -> Int -> Aff Boolean
checkExists conn ts = do
@@ -371,3 +384,8 @@ rowToListen json = do
}
}
}
+
+getTokenUser :: Connection -> String -> Aff (Maybe String)
+getTokenUser conn token = do
+ rows <- queryAll conn "SELECT slug FROM api_tokens WHERE token = ?" [ unsafeCoerce token ]
+ pure $ rows !! 0 >>= toObject >>= Object.lookup "slug" >>= toString
diff --git a/src/Main.purs b/src/Main.purs
@@ -5,16 +5,18 @@ import Prelude
import Config (AppConfig, UserConfig, UserEntry, loadConfig, s3ConfigFromUser)
import Cover (serveCover)
import Cosine (serveSimilar)
+import Data.Argonaut (decodeJson, encodeJson, parseJson, stringify)
import Data.Array (find, length)
+import Data.Array as Data.Array
import Data.Either (Either(..))
-import Data.Foldable (for_)
+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 Db (Connection, FilterField(..), backupDb, connect, getScrobbles, getStats, initDb, initReleaseMetadata, ping)
+import Db (Connection, FilterField(..), backupDb, connect, getOrCreateToken, getScrobbles, getStats, initDb, initReleaseMetadata, ping, upsertScrobble, withTransaction)
import Effect (Effect)
import Effect.Aff (Aff, Fiber, forkAff, joinFiber, killFiber, launchAff_, try)
import Effect.Aff.AVar (AVar)
@@ -36,12 +38,14 @@ import Node.HTTP.Types (ServerResponse, IncomingMessage, IMServer)
import Node.Net.Server (listenTcp, listeningH)
import Node.Process (lookupEnv)
import Node.Stream (end, write, writeString)
-import Data.Argonaut (encodeJson, stringify)
+import Node.Stream.Aff (readableToStringUtf8)
import Sync (lbSync, lbSyncLoop, lfSync, lfSyncLoop)
import Web.URL (URL)
import Web.URL as URL
import Web.URL.URLSearchParams as URLSearchParams
import Templates (indexHtml)
+import Types (Listen(..), ListenBrainzAdditionalInfo(..), ListenBrainzSubmitListen(..), ListenBrainzSubmitPayload(..), ListenBrainzSubmitTrackMetadata(..), MbidMapping(..), TrackMetadata(..))
+import Foreign.Object as Object
-- Types
type Request = IncomingMessage IMServer
@@ -53,6 +57,7 @@ type UserContext =
, writeLock :: AVar Unit
, config :: UserConfig
, slug :: String
+ , token :: String
, displayName :: String
, enrichMetadataFiber :: Maybe (Fiber Unit)
, backupFiber :: Maybe (Fiber Unit)
@@ -78,7 +83,7 @@ handleRequest metricsEnabled contexts req res = do
let path = URL.pathname url
Metrics.wrapRequest method (normalizePath path) Log.info req res do
launchAff_ $ do
- result <- try $ routeRequest metricsEnabled contexts url path allUsers res
+ result <- try $ routeRequest metricsEnabled contexts req url path allUsers res
case result of
Left err -> do
Log.error $ "Internal server error: " <> Exception.message err
@@ -86,8 +91,8 @@ handleRequest metricsEnabled contexts req res = do
Right _ ->
pure unit
-routeRequest :: Boolean -> Array UserContext -> URL -> String -> Array { slug :: String, name :: String } -> Response -> Aff Unit
-routeRequest metricsEnabled contexts url path allUsers res = liftEffect $ case path of
+routeRequest :: Boolean -> Array UserContext -> Request -> URL -> String -> Array { slug :: String, name :: String } -> Response -> Aff Unit
+routeRequest metricsEnabled contexts req url path allUsers res = liftEffect $ case path of
"/client.js" ->
serveClientJs res
"/favicon.png" ->
@@ -109,6 +114,12 @@ routeRequest metricsEnabled contexts url path allUsers res = liftEffect $ case p
withUser url \ctx -> serveSimilar serveBadRequest serveError ctx.slug ctx.config url res
"/healthz" ->
withUser url \ctx -> serveHealthz ctx.conn res
+ "/1/submit-listens" ->
+ if IM.method req == "POST" then
+ withUserFromToken contexts req res \ctx ->
+ launchAff_ $ serveSubmitListens ctx.conn ctx.writeLock req res
+ else
+ serveBadRequest res "Method not allowed"
_ ->
case stripPrefix (Pattern "/u/") path of
Just slug ->
@@ -128,6 +139,24 @@ routeRequest metricsEnabled contexts url path allUsers res = liftEffect $ case p
Just ctx ->
f ctx
+ withUserFromToken contextsParam reqParam resParam f =
+ let
+ headers = IM.headers reqParam
+ mAuth = Object.lookup "authorization" headers
+ mToken = mAuth >>= stripPrefix (Pattern "Token ")
+ in
+ case mToken of
+ Nothing -> do
+ Log.warn "Missing or invalid Authorization header"
+ serveUnauthorized resParam
+ Just tokenValue ->
+ case find (\c -> c.token == tokenValue) contextsParam of
+ Nothing -> do
+ Log.warn $ "Unknown API token provided"
+ serveUnauthorized resParam
+ Just ctx ->
+ f ctx
+
serveIndex :: Array { slug :: String, name :: String } -> String -> Response -> Effect Unit
serveIndex allUsers slug res = do
setHeader "Content-Type" "text/html" (toOutgoingMessage res)
@@ -246,6 +275,53 @@ serveHealthz db res = do
void $ writeString w UTF8 $ """{"status":"error","message":""" <> show (Exception.message err) <> "}"
end w
+serveSubmitListens :: Connection -> AVar Unit -> Request -> Response -> Aff Unit
+serveSubmitListens db lock req res = do
+ body <- readableToStringUtf8 (IM.toReadable req)
+ case parseJson body >>= decodeJson of
+ Left err ->
+ liftEffect $ serveBadRequest res $ "Invalid JSON: " <> show err
+ Right (ListenBrainzSubmitPayload { listenType, payload }) -> do
+ let listens = Data.Array.mapMaybe (submitListenToListen listenType) payload
+ withTransaction db lock $ traverse_ (upsertScrobble db) listens
+ liftEffect $ do
+ setHeader "Content-Type" "application/json" (toOutgoingMessage res)
+ setStatusCode 200 res
+ let w = toWriteable (toOutgoingMessage res)
+ void $ writeString w UTF8 """{"status":"ok"}"""
+ end w
+
+submitListenToListen :: String -> ListenBrainzSubmitListen -> Maybe Listen
+submitListenToListen "single" (ListenBrainzSubmitListen { listenedAt, trackMetadata }) =
+ Just $ Listen
+ { listenedAt
+ , trackMetadata: submitTrackMetadataToTrackMetadata trackMetadata
+ }
+submitListenToListen "import" (ListenBrainzSubmitListen { listenedAt, trackMetadata }) =
+ Just $ Listen
+ { listenedAt
+ , trackMetadata: submitTrackMetadataToTrackMetadata trackMetadata
+ }
+submitListenToListen "playing_now" _ = Nothing
+submitListenToListen _ _ = Nothing
+
+submitTrackMetadataToTrackMetadata :: ListenBrainzSubmitTrackMetadata -> TrackMetadata
+submitTrackMetadataToTrackMetadata (ListenBrainzSubmitTrackMetadata { trackName, artistName, releaseName, additionalInfo }) =
+ TrackMetadata
+ { trackName: Just trackName
+ , artistName: Just artistName
+ , releaseName
+ , genre: Nothing
+ , label: Nothing
+ , mbidMapping: do
+ info <- additionalInfo
+ let ListenBrainzAdditionalInfo i = info
+ pure $ MbidMapping
+ { releaseMbid: i.releaseMbid
+ , caaReleaseMbid: i.releaseMbid
+ }
+ }
+
serveNotFound :: Response -> Effect Unit
serveNotFound res = do
setHeader "Content-Type" "text/plain" (toOutgoingMessage res)
@@ -254,6 +330,14 @@ serveNotFound res = do
void $ writeString w UTF8 "Not Found"
end w
+serveUnauthorized :: Response -> Effect Unit
+serveUnauthorized res = do
+ setHeader "Content-Type" "text/plain" (toOutgoingMessage res)
+ setStatusCode 401 res
+ let w = toWriteable (toOutgoingMessage res)
+ void $ writeString w UTF8 "Unauthorized"
+ end w
+
serveInternalError :: Response -> Effect Unit
serveInternalError res = do
setHeader "Content-Type" "text/plain" (toOutgoingMessage res)
@@ -286,13 +370,13 @@ startUser { slug, name, config } = do
initReleaseMetadata conn
writeLock <- Avar.new unit
+ token <- getOrCreateToken conn slug
+ Log.info $ "User '" <> slug <> "' API token: " <> token
+
case config.lastfmUser, config.lastfmApiKey of
- Just _, Nothing -> Log.warn $ "lastfmUser set for user '" <> slug <> "' but lastfmApiKey is missing — Last.fm sync disabled"
+ Just _, Nothing -> Log.warn $ "User '" <> slug <> "': Last.fm sync disabled (missing API key)"
_, _ -> pure unit
- -- Fork initial syncs; they run in the background so the HTTP server can
- -- 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 (lbSync conn username slug writeLock)
Nothing -> pure Nothing
@@ -300,7 +384,6 @@ startUser { slug, name, config } = do
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.
void $ forkAff do
for_ lbFiber joinFiber
for_ lfFiber joinFiber
@@ -310,14 +393,13 @@ startUser { slug, name, config } = do
Just lfmUser, Just apiKey -> void $ forkAff $ lfSyncLoop conn apiKey lfmUser slug writeLock
_, _ -> pure unit
- -- Background tasks that don't depend on initial sync completion.
enrichMetadataFiber <- forkAff $ enrichMetadata conn config slug
backupFiber <-
if config.backupEnabled then Just <$> forkAff (backupDb conn config.databaseFile (s3ConfigFromUser config) (toNumber config.backupIntervalHours * 3600000.0) slug)
else pure Nothing
let displayName = fromMaybe (if slug == "" then "root" else slug) name
- pure { conn, writeLock, config, slug, displayName, enrichMetadataFiber: Just enrichMetadataFiber, backupFiber }
+ pure { conn, writeLock, config, slug, token, displayName, enrichMetadataFiber: Just enrichMetadataFiber, backupFiber }
cleanupUser :: UserContext -> Aff Unit
cleanupUser ctx = do
@@ -353,4 +435,3 @@ main = do
Log.info $ "Server is running on " <> appConfig.host <> ":" <> show appConfig.port
listenTcp netServer { host: appConfig.host, port: appConfig.port, backlog: 128 }
-
diff --git a/src/Types.purs b/src/Types.purs
@@ -8,6 +8,80 @@ import Data.Maybe (Maybe)
import Data.Generic.Rep (class Generic)
import Data.Show.Generic (genericShow)
+newtype ListenBrainzSubmitPayload = ListenBrainzSubmitPayload
+ { listenType :: String
+ , payload :: Array ListenBrainzSubmitListen
+ }
+
+derive instance eqListenBrainzSubmitPayload :: Eq ListenBrainzSubmitPayload
+derive instance genericListenBrainzSubmitPayload :: Generic ListenBrainzSubmitPayload _
+instance showListenBrainzSubmitPayload :: Show ListenBrainzSubmitPayload where
+ show = genericShow
+
+instance DecodeJson ListenBrainzSubmitPayload where
+ decodeJson json = do
+ obj <- decodeJson json
+ listenType <- obj .: "listen_type"
+ payload <- obj .: "payload"
+ pure $ ListenBrainzSubmitPayload { listenType, payload }
+
+newtype ListenBrainzSubmitListen = ListenBrainzSubmitListen
+ { listenedAt :: Maybe Int
+ , trackMetadata :: ListenBrainzSubmitTrackMetadata
+ }
+
+derive instance eqListenBrainzSubmitListen :: Eq ListenBrainzSubmitListen
+derive instance genericListenBrainzSubmitListen :: Generic ListenBrainzSubmitListen _
+instance showListenBrainzSubmitListen :: Show ListenBrainzSubmitListen where
+ show = genericShow
+
+instance DecodeJson ListenBrainzSubmitListen where
+ decodeJson json = do
+ obj <- decodeJson json
+ listenedAt <- obj .:? "listened_at"
+ trackMetadata <- obj .: "track_metadata"
+ pure $ ListenBrainzSubmitListen { listenedAt, trackMetadata }
+
+newtype ListenBrainzSubmitTrackMetadata = ListenBrainzSubmitTrackMetadata
+ { trackName :: String
+ , artistName :: String
+ , releaseName :: Maybe String
+ , additionalInfo :: Maybe ListenBrainzAdditionalInfo
+ }
+
+derive instance eqListenBrainzSubmitTrackMetadata :: Eq ListenBrainzSubmitTrackMetadata
+derive instance genericListenBrainzSubmitTrackMetadata :: Generic ListenBrainzSubmitTrackMetadata _
+instance showListenBrainzSubmitTrackMetadata :: Show ListenBrainzSubmitTrackMetadata where
+ show = genericShow
+
+instance DecodeJson ListenBrainzSubmitTrackMetadata where
+ decodeJson json = do
+ obj <- decodeJson json
+ trackName <- obj .: "track_name"
+ artistName <- obj .: "artist_name"
+ releaseName <- obj .:? "release_name"
+ additionalInfo <- obj .:? "additional_info"
+ pure $ ListenBrainzSubmitTrackMetadata { trackName, artistName, releaseName, additionalInfo }
+
+newtype ListenBrainzAdditionalInfo = ListenBrainzAdditionalInfo
+ { releaseMbid :: Maybe String
+ , artistMbids :: Maybe (Array String)
+ , recordingMbid :: Maybe String
+ }
+
+derive instance eqListenBrainzAdditionalInfo :: Eq ListenBrainzAdditionalInfo
+derive instance genericListenBrainzAdditionalInfo :: Generic ListenBrainzAdditionalInfo _
+instance showListenBrainzAdditionalInfo :: Show ListenBrainzAdditionalInfo where
+ show = genericShow
+
+instance DecodeJson ListenBrainzAdditionalInfo where
+ decodeJson json = do
+ obj <- decodeJson json
+ releaseMbid <- obj .:? "release_mbid"
+ artistMbids <- obj .:? "artist_mbids"
+ recordingMbid <- obj .:? "recording_mbid"
+ pure $ ListenBrainzAdditionalInfo { releaseMbid, artistMbids, recordingMbid }
+
newtype ListenBrainzResponse = ListenBrainzResponse
{ payload :: Payload
}
