Command.purs (5549B)
1 module Command where 2 3 import Prelude 4 5 import Control.Monad.Error.Class (throwError) 6 import Data.Argonaut (parseJson) 7 import Data.Argonaut.Core (Json, fromArray, fromBoolean, fromNumber, fromObject, fromString, toArray, toObject, toString) 8 import Data.Array (catMaybes, find, snoc) 9 import Data.Array as Array 10 import Data.Either (Either(..)) 11 import Data.Foldable (for_) 12 import Data.Maybe (Maybe(..), fromMaybe, isJust, maybe) 13 import Data.Tuple (Tuple(..)) 14 import Db as Db 15 import Effect.Aff (Aff) 16 import Effect.Class (liftEffect) 17 import Effect.Console (log) 18 import Effect.Exception (error) 19 import Foreign.Object as Object 20 import Node.Encoding (Encoding(UTF8)) 21 import Node.FS.Aff as FSA 22 import Node.Process (cwd, exit', lookupEnv) 23 import Unsafe.Coerce (unsafeCoerce) 24 25 foreign import prettyStringify :: Json -> String 26 27 getFlag :: String -> Array String -> Maybe String 28 getFlag flag args = do 29 { head: k, tail: rest } <- Array.uncons args 30 if k == flag then map _.head (Array.uncons rest) 31 else getFlag flag rest 32 33 resolvePath :: String -> Maybe String -> String -> String 34 resolvePath defaultDir mDbPath file = case mDbPath of 35 Nothing -> defaultDir <> "/" <> file 36 Just dir -> dir <> "/" <> file 37 38 encodeUserEntry 39 :: { slug :: String, name :: Maybe String, dbFile :: String, lbUser :: Maybe String, lfUser :: Maybe String } 40 -> Json 41 encodeUserEntry e = fromObject $ Object.fromFoldable $ catMaybes 42 [ Just $ Tuple "slug" (fromString e.slug) 43 , map (\n -> Tuple "name" (fromString n)) e.name 44 , Just $ Tuple "config" $ fromObject $ Object.fromFoldable $ catMaybes 45 [ Just $ Tuple "databaseFile" (fromString e.dbFile) 46 , map (\u -> Tuple "listenbrainzUser" (fromString u)) e.lbUser 47 , map (\u -> Tuple "lastfmUser" (fromString u)) e.lfUser 48 , Just $ Tuple "coverCacheEnabled" (fromBoolean false) 49 , Just $ Tuple "backupEnabled" (fromBoolean false) 50 , Just $ Tuple "backupIntervalHours" (fromNumber 24.0) 51 ] 52 ] 53 54 readUsersJson :: String -> Aff (Array Json) 55 readUsersJson configFile = do 56 raw <- FSA.readTextFile UTF8 configFile 57 json <- case parseJson raw of 58 Left e -> throwError (error $ "Failed to parse " <> configFile <> ": " <> show e) 59 Right j -> pure j 60 case toObject json >>= Object.lookup "users" >>= toArray of 61 Nothing -> throwError (error "Invalid users.json: expected { users: [...] }") 62 Just arr -> pure arr 63 64 writeUsersJson :: String -> Array Json -> Aff Unit 65 writeUsersJson configFile users = 66 FSA.writeTextFile UTF8 configFile 67 $ prettyStringify 68 $ fromObject 69 $ Object.fromFoldable [ Tuple "users" (fromArray users) ] 70 71 printUsage :: Aff Unit 72 printUsage = liftEffect do 73 log "Usage:" 74 log " add-user --slug <slug> --db <file> [--name <name>] [--listenbrainz-user <user>] [--lastfm-user <user>]" 75 log " reset-token --slug <slug>" 76 log " list-users" 77 exit' 1 78 79 run :: String -> Array String -> Aff Unit 80 run configFile args = do 81 case Array.uncons args of 82 Just { head: "add-user", tail: rest } -> addUser configFile rest 83 Just { head: "reset-token", tail: rest } -> resetToken configFile rest 84 Just { head: "list-users" } -> listUsers configFile 85 _ -> printUsage 86 liftEffect $ exit' 0 87 88 addUser :: String -> Array String -> Aff Unit 89 addUser configFile args = do 90 let 91 mName = getFlag "--name" args 92 mLbUser = getFlag "--listenbrainz-user" args 93 mLfUser = getFlag "--lastfm-user" args 94 slug <- maybe (liftEffect $ log "Error: --slug is required" *> exit' 1) pure (getFlag "--slug" args) 95 dbFile <- maybe (liftEffect $ log "Error: --db is required" *> exit' 1) pure (getFlag "--db" args) 96 users <- readUsersJson configFile 97 when (isJust $ find (\u -> (toObject u >>= Object.lookup "slug" >>= toString) == Just slug) users) 98 $ liftEffect 99 $ log ("Error: user '" <> slug <> "' already exists") *> exit' 1 100 let newEntry = encodeUserEntry { slug, name: mName, dbFile, lbUser: mLbUser, lfUser: mLfUser } 101 writeUsersJson configFile (snoc users newEntry) 102 conn <- Db.connect dbFile 103 Db.initDb conn 104 Db.initReleaseMetadata conn 105 mToken <- Db.getOrCreateToken conn slug 106 liftEffect $ for_ mToken \token -> 107 log $ "Created user '" <> slug <> "'. API token: " <> token 108 109 resetToken :: String -> Array String -> Aff Unit 110 resetToken configFile args = do 111 slug <- maybe (liftEffect $ log "Error: --slug is required" *> exit' 1) pure (getFlag "--slug" args) 112 users <- readUsersJson configFile 113 userJson <- maybe (liftEffect $ log ("Error: user '" <> slug <> "' not found") *> exit' 1) pure 114 $ find (\u -> (toObject u >>= Object.lookup "slug" >>= toString) == Just slug) users 115 dbFile <- maybe (throwError $ error $ "Cannot read databaseFile for user '" <> slug <> "'") pure 116 $ toObject userJson >>= Object.lookup "config" >>= toObject >>= Object.lookup "databaseFile" >>= toString 117 defaultDir <- liftEffect cwd 118 mDbPath <- liftEffect $ lookupEnv "DATABASE_PATH" 119 let fullPath = resolvePath defaultDir mDbPath dbFile 120 conn <- Db.connect fullPath 121 Db.run conn "DELETE FROM api_tokens WHERE slug = ?" [ unsafeCoerce slug ] 122 mToken <- Db.getOrCreateToken conn slug 123 liftEffect $ for_ mToken \token -> 124 log $ "New token for '" <> slug <> "': " <> token 125 126 listUsers :: String -> Aff Unit 127 listUsers configFile = do 128 users <- readUsersJson configFile 129 liftEffect $ for_ users \u -> do 130 let slug = fromMaybe "(root)" (toObject u >>= Object.lookup "slug" >>= toString) 131 let mName = toObject u >>= Object.lookup "name" >>= toString 132 log $ case mName of 133 Just name -> slug <> " (" <> name <> ")" 134 Nothing -> slug