285 lines
7.9 KiB
Haskell
285 lines
7.9 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 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.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, ": ", 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
|
|
-- TODO for some mysterious reason using multithreading just for this
|
|
-- little bit slows the program down by several seconds
|
|
-- lift $ setNumCapabilities threads
|
|
(CRUDOps hSs _ _ _) <- askDBState csHistStmts
|
|
hSs' <- mapErrorsIO (readHistStmt root) hSs
|
|
-- lift $ setNumCapabilities 1
|
|
-- lift $ print $ length $ lefts hSs'
|
|
-- lift $ print $ length $ rights hSs'
|
|
(CRUDOps hTs _ _ _) <- askDBState csHistTrans
|
|
hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
|
|
-- lift $ print $ length $ lefts hTs'
|
|
(CRUDOps bTs _ _ _) <- askDBState csBudgets
|
|
bTs' <- liftIOExceptT $ mapErrors readBudget bTs
|
|
-- lift $ print $ length $ lefts bTs
|
|
return $ concat $ hSs' ++ hTs' ++ bTs'
|
|
-- print $ length $ kmNewCommits state
|
|
-- print $ length $ duOldCommits updates
|
|
-- print $ length $ duNewTagIds updates
|
|
-- print $ length $ duNewAcntPaths updates
|
|
-- print $ length $ duNewAcntIds updates
|
|
-- print $ length $ duNewCurrencyIds updates
|
|
|
|
-- 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 = do
|
|
-- tid <- myThreadId
|
|
-- liftIO $ print $ show tid
|
|
-- liftIO $ print confpath
|
|
liftIO $ Dhall.inputFile Dhall.auto confpath
|