172 lines
4.1 KiB
Haskell
172 lines
4.1 KiB
Haskell
{-# 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
|
|
runDB (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 :: FilePath -> IO ()
|
|
runSync c = do
|
|
config <- readConfig c
|
|
handle err $ runDB (sqlConfig config) $ do
|
|
let bgtRes = liftIOExceptT $ mapErrors insertBudget $ budget config
|
|
let histRes = mapErrorsIO insertStatement $ statements config
|
|
s <- fmap (\f -> f $ takeDirectory c) $ liftIOExceptT $ getDBState config
|
|
flip runReaderT s $ combineErrorIO2 bgtRes histRes $ \_ _ -> ()
|
|
where
|
|
err (InsertException es) = do
|
|
liftIO $ mapM_ TI.putStrLn $ concatMap showError es
|
|
exitFailure
|
|
|
|
-- showBalances
|