pwncash/app/Main.hs

269 lines
7.2 KiB
Haskell

{-# LANGUAGE ImplicitPrelude #-}
module Main (main) where
import Control.Concurrent
import Control.Monad.Except
import Control.Monad.IO.Rerunnable
import Control.Monad.Logger
import Control.Monad.Reader
import Data.Bitraversable
-- import Data.Hashable
import qualified Data.Text.IO as TI
import qualified Database.Esqueleto.Experimental as E
import Database.Persist.Monad
import qualified 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.Map as M
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"
)
type ConfigPath = FilePath
type BudgetPath = FilePath
type HistoryPath = FilePath
data Options = Options !ConfigPath !Mode
data Mode
= Reset
| DumpCurrencies
| DumpAccounts
| DumpAccountKeys
| Sync !SyncOptions
data SyncOptions = SyncOptions
{ syncBudgets :: ![BudgetPath]
, syncHistories :: ![HistoryPath]
, syncThreads :: !Int
}
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"
)
<*> syncOptions
syncOptions :: Parser SyncOptions
syncOptions =
SyncOptions
<$> many
( strOption
( long "budget"
<> short 'b'
<> metavar "BUDGET"
<> help "path to a budget config"
)
)
<*> many
( strOption
( long "history"
<> short 'H'
<> metavar "HISTORY"
<> help "path to a history config"
)
)
<*> option
auto
( long "threads"
<> short 't'
<> metavar "THREADS"
<> value 1
<> help "number of threads for syncing"
)
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 SyncOptions {syncBudgets, syncHistories, syncThreads})) =
runSync syncThreads c syncBudgets syncHistories
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 . accountRFullpath . E.entityVal) $
fst $
indexAcntRoot ar
mapM_ (uncurry printPair) ks
where
printPair i p = do
liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", unAcntID i]
double x = (x, x)
runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO ()
runSync threads c bs hs = do
setNumCapabilities threads
-- putStrLn "reading config"
config <- readConfig c
-- putStrLn "reading statements"
(bs', hs') <-
fmap (bimap concat concat . partitionEithers) $
pooledMapConcurrentlyN threads (bimapM readDhall readDhall) $
(Left <$> bs) ++ (Right <$> hs)
pool <- runNoLoggingT $ mkPool $ sqlConfig config
putStrLn "doing other stuff"
setNumCapabilities 1
handle err $ do
-- _ <- askLoggerIO
-- Get the current DB state.
state <- runSqlQueryT pool $ do
runMigration migrateAll
liftIOExceptT $ readConfigState config bs' hs'
-- 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.
toIns <-
flip runReaderT state $ do
(CRUDOps hSs _ _ _) <- askDBState csHistStmts
hSs' <- mapErrorsIO (readHistStmt root) hSs
(CRUDOps hTs _ _ _) <- askDBState csHistTrans
hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
(CRUDOps bTs _ _ _) <- askDBState csBudgets
bTs' <- liftIOExceptT $ mapErrors readBudget bTs
return $ concat $ hSs' ++ hTs' ++ bTs'
-- Update the DB.
runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
-- NOTE this must come first (unless we defer foreign keys)
updateDBState
res <- runExceptT $ do
(CRUDOps _ bRs bUs _) <- askDBState csBudgets
(CRUDOps _ tRs tUs _) <- askDBState csHistTrans
(CRUDOps _ sRs sUs _) <- askDBState csHistStmts
let ebs = fmap ToUpdate (bUs ++ tUs ++ sUs) ++ fmap ToRead (bRs ++ tRs ++ sRs) ++ fmap ToInsert toIns
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 = fmap unfix . readDhall
readDhall :: Dhall.FromDhall a => MonadUnliftIO m => FilePath -> m a
readDhall confpath = liftIO $ Dhall.inputFile Dhall.auto confpath