commit 46342937d0b13c07b83b52da390a90121ea8ccff
parent 624f573fb457573984b394644455ca92eeb11b1b
Author: mtmn <miro@haravara.org>
Date: Fri, 24 Apr 2026 20:17:02 +0200
chore: install purescript-language-server
Diffstat:
6 files changed, 282 insertions(+), 19 deletions(-)
diff --git a/flake.nix b/flake.nix
@@ -131,7 +131,7 @@
inherit ((builtins.fromJSON (builtins.readFile ./package.json))) version;
inherit src;
- npmDepsHash = "sha256-c6rRnzceItLPD/AdylbO8kyA9AqBHYrcV+s9vTB8z68=";
+ npmDepsHash = "sha256-eqRRymOtj92bzH0yHCrvq72ATwPEwB4bfqpmu+5HHmE=";
npmRebuildFlags = ["--ignore-scripts"];
nativeBuildInputs = with pkgs; [
diff --git a/package-lock.json b/package-lock.json
@@ -19,6 +19,7 @@
"elm": "^0.19.1",
"esbuild": "^0.28.0",
"purescript": "^0.15.16",
+ "purescript-language-server": "^0.18.5",
"purescript-psa": "^0.9.0",
"purs-backend-es": "^1.4.3",
"purs-tidy": "^0.11.1",
@@ -5493,6 +5494,42 @@
"which": "bin/which"
}
},
+ "node_modules/purescript-language-server": {
+ "version": "0.18.5",
+ "resolved": "https://registry.npmjs.org/purescript-language-server/-/purescript-language-server-0.18.5.tgz",
+ "integrity": "sha512-taYQdwg9ZDV4foF0o+GDQ+oaoUyThqoufsnlRvZjhGHNmU+M2vGjkG2gpBbxiSVKFA58wqWy9WZf5MEE83TzZg==",
+ "dev": true,
+ "license": "MIT",
+ "dependencies": {
+ "shell-quote": "^1.7.2",
+ "uuid": "^9.0.0",
+ "vscode-jsonrpc": "^8.0.0-next.2",
+ "vscode-languageserver": "^8.0.0-next.2",
+ "vscode-languageserver-textdocument": "^1.0.1",
+ "vscode-uri": "^2.1.1",
+ "which": "^2.0.2"
+ },
+ "bin": {
+ "purescript-language-server": "server.js"
+ },
+ "engines": {
+ "node": ">=14"
+ }
+ },
+ "node_modules/purescript-language-server/node_modules/uuid": {
+ "version": "9.0.1",
+ "resolved": "https://registry.npmjs.org/uuid/-/uuid-9.0.1.tgz",
+ "integrity": "sha512-b+1eJOlsR9K8HJpow9Ok3fiWOWSIcIzXodvv0rQjVoOVNpWMpxf1wZNpt4y9h10odCNrqnYp1OBzRktckBe3sA==",
+ "dev": true,
+ "funding": [
+ "https://github.com/sponsors/broofa",
+ "https://github.com/sponsors/ctavan"
+ ],
+ "license": "MIT",
+ "bin": {
+ "uuid": "dist/bin/uuid"
+ }
+ },
"node_modules/purescript-psa": {
"version": "0.9.0",
"resolved": "https://registry.npmjs.org/purescript-psa/-/purescript-psa-0.9.0.tgz",
@@ -5838,6 +5875,19 @@
"node": ">=8"
}
},
+ "node_modules/shell-quote": {
+ "version": "1.8.3",
+ "resolved": "https://registry.npmjs.org/shell-quote/-/shell-quote-1.8.3.tgz",
+ "integrity": "sha512-ObmnIF4hXNg1BqhnHmgbDETF8dLPCggZWBjkQfhZpbszZnYur5DUljTcCHii5LC3J5E0yeO/1LIMyH+UvHQgyw==",
+ "dev": true,
+ "license": "MIT",
+ "engines": {
+ "node": ">= 0.4"
+ },
+ "funding": {
+ "url": "https://github.com/sponsors/ljharb"
+ }
+ },
"node_modules/signal-exit": {
"version": "3.0.7",
"resolved": "https://registry.npmjs.org/signal-exit/-/signal-exit-3.0.7.tgz",
@@ -6553,6 +6603,71 @@
"dev": true,
"license": "MIT"
},
+ "node_modules/vscode-jsonrpc": {
+ "version": "8.2.1",
+ "resolved": "https://registry.npmjs.org/vscode-jsonrpc/-/vscode-jsonrpc-8.2.1.tgz",
+ "integrity": "sha512-kdjOSJ2lLIn7r1rtrMbbNCHjyMPfRnowdKjBQ+mGq6NAW5QY2bEZC/khaC5OR8svbbjvLEaIXkOq45e2X9BIbQ==",
+ "dev": true,
+ "license": "MIT",
+ "engines": {
+ "node": ">=14.0.0"
+ }
+ },
+ "node_modules/vscode-languageserver": {
+ "version": "8.1.0",
+ "resolved": "https://registry.npmjs.org/vscode-languageserver/-/vscode-languageserver-8.1.0.tgz",
+ "integrity": "sha512-eUt8f1z2N2IEUDBsKaNapkz7jl5QpskN2Y0G01T/ItMxBxw1fJwvtySGB9QMecatne8jFIWJGWI61dWjyTLQsw==",
+ "dev": true,
+ "license": "MIT",
+ "dependencies": {
+ "vscode-languageserver-protocol": "3.17.3"
+ },
+ "bin": {
+ "installServerIntoExtension": "bin/installServerIntoExtension"
+ }
+ },
+ "node_modules/vscode-languageserver-protocol": {
+ "version": "3.17.3",
+ "resolved": "https://registry.npmjs.org/vscode-languageserver-protocol/-/vscode-languageserver-protocol-3.17.3.tgz",
+ "integrity": "sha512-924/h0AqsMtA5yK22GgMtCYiMdCOtWTSGgUOkgEDX+wk2b0x4sAfLiO4NxBxqbiVtz7K7/1/RgVrVI0NClZwqA==",
+ "dev": true,
+ "license": "MIT",
+ "dependencies": {
+ "vscode-jsonrpc": "8.1.0",
+ "vscode-languageserver-types": "3.17.3"
+ }
+ },
+ "node_modules/vscode-languageserver-protocol/node_modules/vscode-jsonrpc": {
+ "version": "8.1.0",
+ "resolved": "https://registry.npmjs.org/vscode-jsonrpc/-/vscode-jsonrpc-8.1.0.tgz",
+ "integrity": "sha512-6TDy/abTQk+zDGYazgbIPc+4JoXdwC8NHU9Pbn4UJP1fehUyZmM4RHp5IthX7A6L5KS30PRui+j+tbbMMMafdw==",
+ "dev": true,
+ "license": "MIT",
+ "engines": {
+ "node": ">=14.0.0"
+ }
+ },
+ "node_modules/vscode-languageserver-textdocument": {
+ "version": "1.0.12",
+ "resolved": "https://registry.npmjs.org/vscode-languageserver-textdocument/-/vscode-languageserver-textdocument-1.0.12.tgz",
+ "integrity": "sha512-cxWNPesCnQCcMPeenjKKsOCKQZ/L6Tv19DTRIGuLWe32lyzWhihGVJ/rcckZXJxfdKCFvRLS3fpBIsV/ZGX4zA==",
+ "dev": true,
+ "license": "MIT"
+ },
+ "node_modules/vscode-languageserver-types": {
+ "version": "3.17.3",
+ "resolved": "https://registry.npmjs.org/vscode-languageserver-types/-/vscode-languageserver-types-3.17.3.tgz",
+ "integrity": "sha512-SYU4z1dL0PyIMd4Vj8YOqFvHu7Hz/enbWtpfnVbJHU4Nd1YNYx8u0ennumc6h48GQNeOLxmwySmnADouT/AuZA==",
+ "dev": true,
+ "license": "MIT"
+ },
+ "node_modules/vscode-uri": {
+ "version": "2.1.2",
+ "resolved": "https://registry.npmjs.org/vscode-uri/-/vscode-uri-2.1.2.tgz",
+ "integrity": "sha512-8TEXQxlldWAuIODdukIb+TR5s+9Ds40eSJrw+1iDDA9IFORPjMELarNQE3myz5XIkWWpdprmJjm1/SxMlWOC8A==",
+ "dev": true,
+ "license": "MIT"
+ },
"node_modules/webidl-conversions": {
"version": "3.0.1",
"resolved": "https://registry.npmjs.org/webidl-conversions/-/webidl-conversions-3.0.1.tgz",
diff --git a/package.json b/package.json
@@ -14,6 +14,7 @@
"elm": "^0.19.1",
"esbuild": "^0.28.0",
"purescript": "^0.15.16",
+ "purescript-language-server": "^0.18.5",
"purescript-psa": "^0.9.0",
"purs-backend-es": "^1.4.3",
"purs-tidy": "^0.11.1",
diff --git a/src/Command.js b/src/Command.js
@@ -0,0 +1 @@
+export const prettyStringify = (json) => JSON.stringify(json, null, 2) + "\n";
diff --git a/src/Command.purs b/src/Command.purs
@@ -0,0 +1,140 @@
+module Command where
+
+import Prelude
+
+import Control.Monad.Error.Class (throwError)
+import Data.Argonaut (parseJson)
+import Data.Argonaut.Core (Json, fromArray, fromBoolean, fromNumber, fromObject, fromString, toArray, toObject, toString)
+import Data.Array (catMaybes, find, snoc)
+import Data.Array as Array
+import Data.Either (Either(..))
+import Data.Foldable (for_)
+import Data.Maybe (Maybe(..), fromMaybe)
+import Data.Tuple (Tuple(..))
+import Db as Db
+import Effect.Aff (Aff)
+import Effect.Class (liftEffect)
+import Effect.Console (log)
+import Effect.Exception (error)
+import Foreign.Object as Object
+import Node.Encoding (Encoding(UTF8))
+import Node.FS.Aff as FSA
+import Node.Process (cwd, exit, lookupEnv)
+import Unsafe.Coerce (unsafeCoerce)
+
+foreign import prettyStringify :: Json -> String
+
+getFlag :: String -> Array String -> Maybe String
+getFlag flag args = case Array.uncons args of
+ Nothing -> Nothing
+ Just { head: k, tail: rest } ->
+ if k == flag then map _.head (Array.uncons rest)
+ else getFlag flag rest
+
+resolvePath :: String -> Maybe String -> String -> String
+resolvePath defaultDir mDbPath file = case mDbPath of
+ Nothing -> defaultDir <> "/" <> file
+ Just dir -> dir <> "/" <> file
+
+encodeUserEntry
+ :: { slug :: String, name :: Maybe String, dbFile :: String, lbUser :: Maybe String, lfUser :: Maybe String }
+ -> Json
+encodeUserEntry e = fromObject $ Object.fromFoldable $ catMaybes
+ [ Just $ Tuple "slug" (fromString e.slug)
+ , map (\n -> Tuple "name" (fromString n)) e.name
+ , Just $ Tuple "config" $ fromObject $ Object.fromFoldable $ catMaybes
+ [ Just $ Tuple "databaseFile" (fromString e.dbFile)
+ , map (\u -> Tuple "listenbrainzUser" (fromString u)) e.lbUser
+ , map (\u -> Tuple "lastfmUser" (fromString u)) e.lfUser
+ , Just $ Tuple "coverCacheEnabled" (fromBoolean false)
+ , Just $ Tuple "backupEnabled" (fromBoolean false)
+ , Just $ Tuple "backupIntervalHours" (fromNumber 24.0)
+ ]
+ ]
+
+readUsersJson :: String -> Aff (Array Json)
+readUsersJson configFile = do
+ raw <- FSA.readTextFile UTF8 configFile
+ json <- case parseJson raw of
+ Left e -> throwError (error $ "Failed to parse " <> configFile <> ": " <> show e)
+ Right j -> pure j
+ case toObject json >>= Object.lookup "users" >>= toArray of
+ Nothing -> throwError (error "Invalid users.json: expected { users: [...] }")
+ Just arr -> pure arr
+
+writeUsersJson :: String -> Array Json -> Aff Unit
+writeUsersJson configFile users =
+ FSA.writeTextFile UTF8 configFile
+ $ prettyStringify
+ $ fromObject
+ $ Object.fromFoldable [ Tuple "users" (fromArray users) ]
+
+run :: String -> Array String -> Aff Unit
+run configFile args = case Array.uncons args of
+ Just { head: "add-user", tail: rest } -> addUser configFile rest
+ Just { head: "reset-token", tail: rest } -> resetToken configFile rest
+ Just { head: "list-users" } -> listUsers configFile
+ _ -> liftEffect do
+ log "Usage:"
+ log " add-user --slug <slug> --db <file> [--name <name>] [--listenbrainz-user <user>] [--lastfm-user <user>]"
+ log " reset-token --slug <slug>"
+ log " list-users"
+ exit 1
+
+addUser :: String -> Array String -> Aff Unit
+addUser configFile args = do
+ let
+ mSlug = getFlag "--slug" args
+ mDb = getFlag "--db" args
+ mName = getFlag "--name" args
+ mLbUser = getFlag "--listenbrainz-user" args
+ mLfUser = getFlag "--lastfm-user" args
+ case mSlug, mDb of
+ Nothing, _ -> liftEffect $ log "Error: --slug is required" *> exit 1
+ _, Nothing -> liftEffect $ log "Error: --db is required" *> exit 1
+ Just slug, Just dbFile -> do
+ users <- readUsersJson configFile
+ case find (\u -> (toObject u >>= Object.lookup "slug" >>= toString) == Just slug) users of
+ Just _ -> liftEffect $ log ("Error: user '" <> slug <> "' already exists") *> exit 1
+ Nothing -> do
+ let newEntry = encodeUserEntry { slug, name: mName, dbFile, lbUser: mLbUser, lfUser: mLfUser }
+ writeUsersJson configFile (snoc users newEntry)
+ conn <- Db.connect dbFile
+ Db.initDb conn
+ Db.initReleaseMetadata conn
+ mToken <- Db.getOrCreateToken conn slug
+ liftEffect $ for_ mToken \token ->
+ log $ "Created user '" <> slug <> "'. API token: " <> token
+
+resetToken :: String -> Array String -> Aff Unit
+resetToken configFile args = do
+ let mSlug = getFlag "--slug" args
+ case mSlug of
+ Nothing -> liftEffect $ log "Error: --slug is required" *> exit 1
+ Just slug -> do
+ users <- readUsersJson configFile
+ case find (\u -> (toObject u >>= Object.lookup "slug" >>= toString) == Just slug) users of
+ Nothing -> liftEffect $ log ("Error: user '" <> slug <> "' not found") *> exit 1
+ Just userJson -> do
+ let mDbFile = toObject userJson >>= Object.lookup "config" >>= toObject >>= Object.lookup "databaseFile" >>= toString
+ case mDbFile of
+ Nothing -> throwError (error $ "Cannot read databaseFile for user '" <> slug <> "'")
+ Just dbFile -> do
+ defaultDir <- liftEffect cwd
+ mDbPath <- liftEffect $ lookupEnv "DATABASE_PATH"
+ let fullPath = resolvePath defaultDir mDbPath dbFile
+ conn <- Db.connect fullPath
+ Db.run conn "DELETE FROM api_tokens WHERE slug = ?" [ unsafeCoerce slug ]
+ mToken <- Db.getOrCreateToken conn slug
+ liftEffect $ for_ mToken \token ->
+ log $ "New token for '" <> slug <> "': " <> token
+
+listUsers :: String -> Aff Unit
+listUsers configFile = do
+ users <- readUsersJson configFile
+ liftEffect $ for_ users \u -> do
+ let slug = fromMaybe "(root)" (toObject u >>= Object.lookup "slug" >>= toString)
+ let mName = toObject u >>= Object.lookup "name" >>= toString
+ log $ case mName of
+ Just name -> slug <> " (" <> name <> ")"
+ Nothing -> slug
diff --git a/src/Main.purs b/src/Main.purs
@@ -36,13 +36,14 @@ 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.Process (lookupEnv)
+import Node.Process (argv, lookupEnv)
import Node.Stream (end, write, writeString)
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 Command as Command
import Templates (indexHtml)
import Types (Listen(..), ListenBrainzAdditionalInfo(..), ListenBrainzSubmitListen(..), ListenBrainzSubmitPayload(..), ListenBrainzSubmitTrackMetadata(..), MbidMapping(..), TrackMetadata(..))
import Foreign.Object as Object
@@ -436,20 +437,25 @@ main = do
dotenvConfig
launchAff_ do
configFile <- liftEffect $ map (fromMaybe "users.json") $ lookupEnv "CORPUS_USERS_FILE"
- result <- try $ loadConfig configFile
- case result of
- Left err -> do
- Log.error $ "Failed to load " <> configFile <> ": " <> Exception.message err
- liftEffect $ Exception.throwException err
- Right (appConfig :: AppConfig) -> do
- Log.info $ "Loaded " <> show (length appConfig.users) <> " user(s) from " <> configFile
- contexts <- traverse startUser appConfig.users
- liftEffect $ do
- server <- createServer
- server # on_ Server.requestH (handleRequest appConfig.metricsEnabled contexts)
- let netServer = Server.toNetServer server
-
- netServer # on_ listeningH do
- Log.info $ "Server is running on " <> appConfig.host <> ":" <> show appConfig.port
-
- listenTcp netServer { host: appConfig.host, port: appConfig.port, backlog: 128 }
+ args <- liftEffect argv
+ let commandArgs = Data.Array.drop 2 args
+ case Data.Array.uncons commandArgs of
+ Just _ -> Command.run configFile commandArgs
+ Nothing -> do
+ result <- try $ loadConfig configFile
+ case result of
+ Left err -> do
+ Log.error $ "Failed to load " <> configFile <> ": " <> Exception.message err
+ liftEffect $ Exception.throwException err
+ Right (appConfig :: AppConfig) -> do
+ Log.info $ "Loaded " <> show (length appConfig.users) <> " user(s) from " <> configFile
+ contexts <- traverse startUser appConfig.users
+ liftEffect $ do
+ server <- createServer
+ server # on_ Server.requestH (handleRequest appConfig.metricsEnabled contexts)
+ let netServer = Server.toNetServer server
+
+ netServer # on_ listeningH do
+ Log.info $ "Server is running on " <> appConfig.host <> ":" <> show appConfig.port
+
+ listenTcp netServer { host: appConfig.host, port: appConfig.port, backlog: 128 }
