pwncash/app/Main.hs

208 lines
5.5 KiB
Haskell

{-# LANGUAGE ImplicitPrelude #-}
module Main (main) where
import Control.Monad.Except
import Control.Monad.IO.Rerunnable
import Control.Monad.Logger
import Control.Monad.Reader
import qualified Data.Text.IO as TI
import Database.Persist.Monad
import Dhall hiding (double, record)
import Internal.Budget
import Internal.Database
import Internal.History
import Internal.Types.Main
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
pool <- runNoLoggingT $ mkPool $ sqlConfig config
handle err $ do
-- _ <- askLoggerIO
-- Get the current DB state.
(state, updates) <- runSqlQueryT pool $ do
runMigration migrateAll
liftIOExceptT $ getDBState config
-- Read raw transactions according to state. If a transaction is already in
-- the database, don't read it but record the commit so we can update it.
(rus, is) <-
flip runReaderT state $ do
let (hTs, hSs) = splitHistory $ statements config
hSs' <- mapErrorsIO (readHistStmt root) hSs
hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
bTs <- liftIOExceptT $ mapErrors readBudget $ budget config
return $ second concat $ partitionEithers $ hSs' ++ hTs' ++ bTs
-- Update the DB.
runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
-- NOTE this must come first (unless we defer foreign keys)
updateDBState updates
res <- runExceptT $ do
-- TODO taking out the hash is dumb
(rs, ues) <- readUpdates $ fmap commitRHash rus
let ebs = fmap ToUpdate ues ++ fmap ToRead rs ++ fmap ToInsert is
insertAll ebs
-- NOTE this rerunnable thing is a bit misleading; fromEither will throw
-- whatever error is encountered above in an IO context, but the first
-- thrown error should be caught despite possibly needing to be rerun
rerunnableIO $ fromEither res
where
root = takeDirectory c
err (InsertException es) = do
liftIO $ mapM_ TI.putStrLn $ concatMap showError es
exitFailure
-- showBalances
readConfig :: MonadUnliftIO m => FilePath -> m Config
readConfig confpath = liftIO $ unfix <$> Dhall.inputFile Dhall.auto confpath