Something went wrong. Try again.
self-hosted listenbrainz and last.fm proxy
Something went wrong. Try again.
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178module Command (run) 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 Arrayimport Data.Either (Either(..))import Data.Foldable (for_)import Data.Maybe (Maybe(..), fromMaybe, isJust, maybe)import Data.Tuple (Tuple(..))import Db as Dbimport Effect.Aff (Aff)import Effect.Class (liftEffect)import Effect.Console (log)import Effect.Exception (error)import Foreign.Object as Objectimport Node.Encoding (Encoding(UTF8))import Node.FS.Aff as FSAimport Node.Process (cwd, exit', lookupEnv)
foreign import prettyStringify :: Json -> String
getFlag :: String -> Array String -> Maybe StringgetFlag flag args = do { head: k, tail: rest } <- Array.uncons args if k == flag then map _.head (Array.uncons rest) else getFlag flag rest
resolvePath :: String -> Maybe String -> String -> StringresolvePath 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 } -> JsonencodeUserEntry 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 UnitwriteUsersJson configFile users = FSA.writeTextFile UTF8 configFile $ prettyStringify $ fromObject $ Object.fromFoldable [ Tuple "users" (fromArray users) ]
printUsage :: Aff UnitprintUsage = 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
-- | Run the administrative command selected by the process arguments.run :: String -> Array String -> Aff Unitrun configFile args = do 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 _ -> printUsage liftEffect $ exit' 0
addUser :: String -> Array String -> Aff UnitaddUser configFile args = do let mName = getFlag "--name" args mLbUser = getFlag "--listenbrainz-user" args mLfUser = getFlag "--lastfm-user" args slug <- maybe (liftEffect $ log "Error: --slug is required" *> exit' 1) pure (getFlag "--slug" args) dbFile <- maybe (liftEffect $ log "Error: --db is required" *> exit' 1) pure (getFlag "--db" args) users <- readUsersJson configFile when ( isJust $ find (\u -> (toObject u >>= Object.lookup "slug" >>= toString) == Just slug) users ) $ liftEffect $ log ("Error: user '" <> slug <> "' already exists") *> exit' 1 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 UnitresetToken configFile args = do slug <- maybe (liftEffect $ log "Error: --slug is required" *> exit' 1) pure (getFlag "--slug" args) users <- readUsersJson configFile userJson <- maybe (liftEffect $ log ("Error: user '" <> slug <> "' not found") *> exit' 1) pure $ find ( \u -> (toObject u >>= Object.lookup "slug" >>= toString) == Just slug ) users dbFile <- maybe ( throwError $ error $ "Cannot read databaseFile for user '" <> slug <> "'" ) pure $ toObject userJson >>= Object.lookup "config" >>= toObject >>= Object.lookup "databaseFile" >>= toString 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 = ?" [ Db.toParam slug ] mToken <- Db.getOrCreateToken conn slug liftEffect $ for_ mToken \token -> log $ "New token for '" <> slug <> "': " <> token
listUsers :: String -> Aff UnitlistUsers 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