pwncash/app/Main.hs

{-# LANGUAGE ImplicitPrelude #-}

module Main (main) where

import Control.Monad.Reader
import qualified Data.Text.IO as TI
import Internal.Config
import Internal.Database.Ops
import Internal.Insert
import Internal.Types
import Internal.Utils
import Options.Applicative
import RIO
import RIO.FilePath
import qualified RIO.Text as T

main :: IO ()
main = parse =<< execParser o
  where
    o =
      info
        (options <**> helper)
        ( fullDesc
            <> progDesc "Pwn your budget"
            <> header "pwncash - your budget, your life"
        )

data Options = Options FilePath Mode

data Mode
  = Reset
  | DumpCurrencies
  | DumpAccounts
  | DumpAccountKeys
  | Sync

configFile :: Parser FilePath
configFile =
  strOption
    ( long "config"
        <> short 'c'
        <> metavar "CONFIG"
        <> value "main.dhall"
        <> help "config file to use"
    )

options :: Parser Options
options =
  getConf reset
    <|> getConf dumpCurrencies
    <|> getConf dumpAccounts
    <|> getConf dumpAccountKeys
    <|> getConf sync
  where
    getConf m = Options <$> configFile <*> m

reset :: Parser Mode
reset =
  flag'
    Reset
    ( long "reset"
        <> short 'R'
        <> help "Reset the database"
    )

dumpCurrencies :: Parser Mode
dumpCurrencies =
  flag'
    DumpCurrencies
    ( long "currencies"
        <> short 'C'
        <> help "Dump all currencies in the configuration"
    )

dumpAccounts :: Parser Mode
dumpAccounts =
  flag'
    DumpAccounts
    ( long "accounts"
        <> short 'A'
        <> help "Dump all accounts in the configuration"
    )

-- TODO 'alias' is a better name for these
dumpAccountKeys :: Parser Mode
dumpAccountKeys =
  flag'
    DumpAccountKeys
    ( long "account_keys"
        <> short 'K'
        <> help "Dump all account keys/aliases"
    )

sync :: Parser Mode
sync =
  flag'
    Sync
    ( long "sync"
        <> short 'S'
        <> help "Sync config to database"
    )

parse :: Options -> IO ()
parse (Options c Reset) = do
  config <- readConfig c
  migrate_ (sqlConfig config) nukeTables
parse (Options c DumpAccounts) = runDumpAccounts c
parse (Options c DumpAccountKeys) = runDumpAccountKeys c
parse (Options c DumpCurrencies) = runDumpCurrencies c
parse (Options c Sync) = runSync c

runDumpCurrencies :: MonadUnliftIO m => FilePath -> m ()
runDumpCurrencies c = do
  cs <- currencies <$> readConfig c
  liftIO $ putStrLn $ T.unpack $ T.unlines $ fmap fmt cs
  where
    fmt Currency {curSymbol = s, curFullname = f} =
      T.concat [s, ": ", f]

runDumpAccounts :: MonadUnliftIO m => FilePath -> m ()
runDumpAccounts c = do
  ar <- accounts <$> readConfig c
  mapM_ (\(h, f) -> printTree h $ f ar) ps
  where
    ps =
      [ ("Assets", arAssets)
      , ("Equity", arEquity)
      , ("Expenses", arExpenses)
      , ("Income", arIncome)
      , ("Liabilities", arLiabilities)
      ]
    printTree h ts = do
      liftIO $ putStrLn h
      mapM (go 1) ts
    go i (Placeholder d n cs) = do
      printAcnt i d n
      mapM_ (go (i + 1)) cs
    go i (Account d n) = printAcnt i d n
    printAcnt i d n = do
      let ind = T.replicate (i * 2) " "
      liftIO $ putStrLn $ T.unpack $ T.concat [ind, n, ": ", d]

runDumpAccountKeys :: MonadUnliftIO m => FilePath -> m ()
runDumpAccountKeys c = do
  ar <- accounts <$> readConfig c
  let ks =
        paths2IDs $
          fmap (double . fst) $
            concatMap (t3 . uncurry tree2Records) $
              flattenAcntRoot ar
  mapM_ (uncurry printPair) ks
  where
    printPair i p = do
      liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", i]
    t3 (_, _, x) = x
    double x = (x, x)

runSync :: MonadUnliftIO m => FilePath -> m ()
runSync c = do
  config <- readConfig c
  handle err $ migrate_ (sqlConfig config) $ do
    res <- getDBState config
    case res of
      Left es -> throwIO $ InsertException es
      Right s -> do
        let run = mapReaderT $ flip runReaderT (s $ takeDirectory c)
        es1 <- concat <$> mapM (run . insertBudget) (budget config)
        es2 <- run $ insertStatements config
        let es = es1 ++ es2
        unless (null es) $ throwIO $ InsertException es
  where
    err (InsertException es) = do
      liftIO $ mapM_ TI.putStrLn $ concatMap showError es
      exitFailure

-- showBalances