pwncash/app/Main.hs

174 lines
4.1 KiB
Haskell

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Main (main) where
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
catch (sync_ config) $ \case
InsertException _ -> liftIO $ putStrLn "insert error"
where
sync_ config = migrate_ (sqlConfig config) $ do
res <- getDBState config
case res of
Left es -> throwIO $ InsertException es
Right s -> flip runReaderT (s $ takeDirectory c) $ do
es1 <- insertBudget $ budget config
es2 <- insertStatements config
let es = es1 ++ es2
unless (null es) $ throwIO $ InsertException es
-- showBalances