pwncash/app/Main.hs

286 lines
7.9 KiB
Haskell
Raw Normal View History

2023-02-12 16:23:32 -05:00
{-# LANGUAGE ImplicitPrelude #-}
2022-12-11 17:51:11 -05:00
module Main (main) where
import Control.Concurrent
2023-05-13 13:53:43 -04:00
import Control.Monad.Except
import Control.Monad.IO.Rerunnable
import Control.Monad.Logger
2023-02-12 16:23:32 -05:00
import Control.Monad.Reader
import Data.Bitraversable
import qualified Data.Text.IO as TI
2023-05-13 13:53:43 -04:00
import Database.Persist.Monad
import qualified Dhall hiding (double, record)
2023-05-29 15:56:15 -04:00
import Internal.Budget
2023-05-29 17:33:59 -04:00
import Internal.Database
2023-05-29 15:56:15 -04:00
import Internal.History
import Internal.Types.Main
import Internal.Utils
import Options.Applicative
import RIO
import RIO.FilePath
import qualified RIO.Text as T
2022-12-11 18:34:05 -05:00
2022-12-11 17:51:11 -05:00
main :: IO ()
main = parse =<< execParser o
where
o =
info
(options <**> helper)
( fullDesc
<> progDesc "Pwn your budget"
<> header "pwncash - your budget, your life"
)
2022-12-11 17:51:11 -05:00
type ConfigPath = FilePath
type BudgetPath = FilePath
type HistoryPath = FilePath
data Options = Options !ConfigPath !Mode
2022-12-11 18:34:05 -05:00
data Mode
= Reset
2022-12-11 17:51:11 -05:00
| DumpCurrencies
| DumpAccounts
| DumpAccountKeys
| Sync !SyncOptions
data SyncOptions = SyncOptions
{ syncBudgets :: ![BudgetPath]
, syncHistories :: ![HistoryPath]
, syncThreads :: !Int
}
2022-12-11 17:51:11 -05:00
2022-12-11 18:34:05 -05:00
configFile :: Parser FilePath
configFile =
strOption
( long "config"
<> short 'c'
<> metavar "CONFIG"
<> value "main.dhall"
<> help "config file to use"
)
2022-12-11 18:34:05 -05:00
2022-12-11 17:51:11 -05:00
options :: Parser Options
options =
getConf reset
<|> getConf dumpCurrencies
<|> getConf dumpAccounts
<|> getConf dumpAccountKeys
<|> getConf sync
2022-12-11 18:34:05 -05:00
where
getConf m = Options <$> configFile <*> m
2022-12-11 17:51:11 -05:00
2022-12-11 18:34:05 -05:00
reset :: Parser Mode
reset =
flag'
Reset
( long "reset"
<> short 'R'
<> help "Reset the database"
)
2022-12-11 17:51:11 -05:00
2022-12-11 18:34:05 -05:00
dumpCurrencies :: Parser Mode
dumpCurrencies =
flag'
DumpCurrencies
( long "currencies"
<> short 'C'
<> help "Dump all currencies in the configuration"
)
2022-12-11 17:51:11 -05:00
2022-12-11 18:34:05 -05:00
dumpAccounts :: Parser Mode
dumpAccounts =
flag'
DumpAccounts
( long "accounts"
<> short 'A'
<> help "Dump all accounts in the configuration"
)
2022-12-11 17:51:11 -05:00
-- TODO 'alias' is a better name for these
2022-12-11 18:34:05 -05:00
dumpAccountKeys :: Parser Mode
dumpAccountKeys =
flag'
DumpAccountKeys
( long "account_keys"
<> short 'K'
<> help "Dump all account keys/aliases"
)
2022-12-11 17:51:11 -05:00
2022-12-11 18:34:05 -05:00
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"
)
2022-12-11 17:51:11 -05:00
parse :: Options -> IO ()
parse (Options c Reset) = do
2022-12-11 18:53:54 -05:00
config <- readConfig c
2023-05-07 20:29:33 -04:00
runDB (sqlConfig config) nukeTables
parse (Options c DumpAccounts) = runDumpAccounts c
2022-12-11 18:34:05 -05:00
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
2022-12-11 18:34:05 -05:00
2023-01-05 22:23:22 -05:00
runDumpCurrencies :: MonadUnliftIO m => FilePath -> m ()
2022-12-11 18:34:05 -05:00
runDumpCurrencies c = do
cs <- currencies <$> readConfig c
2023-01-05 22:23:22 -05:00
liftIO $ putStrLn $ T.unpack $ T.unlines $ fmap fmt cs
2022-12-11 17:51:11 -05:00
where
fmt Currency {curSymbol = s, curFullname = f} =
2022-12-11 17:51:11 -05:00
T.concat [s, ": ", f]
2023-01-05 22:23:22 -05:00
runDumpAccounts :: MonadUnliftIO m => FilePath -> m ()
2022-12-11 18:34:05 -05:00
runDumpAccounts c = do
ar <- accounts <$> readConfig c
2022-12-11 17:51:11 -05:00
mapM_ (\(h, f) -> printTree h $ f ar) ps
where
ps =
[ ("Assets", arAssets)
, ("Equity", arEquity)
, ("Expenses", arExpenses)
, ("Income", arIncome)
, ("Liabilities", arLiabilities)
]
2022-12-11 17:51:11 -05:00
printTree h ts = do
2023-01-05 22:23:22 -05:00
liftIO $ putStrLn h
2022-12-11 17:51:11 -05:00
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) " "
2023-01-05 22:23:22 -05:00
liftIO $ putStrLn $ T.unpack $ T.concat [ind, n, ": ", d]
2022-12-11 17:51:11 -05:00
2023-01-05 22:23:22 -05:00
runDumpAccountKeys :: MonadUnliftIO m => FilePath -> m ()
2022-12-11 18:34:05 -05:00
runDumpAccountKeys c = do
ar <- accounts <$> readConfig c
let ks =
paths2IDs $
fmap (double . fst) $
concatMap (t3 . uncurry tree2Records) $
flattenAcntRoot ar
2022-12-11 17:51:11 -05:00
mapM_ (uncurry printPair) ks
where
printPair i p = do
2023-01-05 22:23:22 -05:00
liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", i]
2022-12-11 17:51:11 -05:00
t3 (_, _, x) = x
double x = (x, x)
runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO ()
runSync threads c bs hs = do
setNumCapabilities threads
-- putStrLn "reading config"
2022-12-11 18:34:05 -05:00
config <- readConfig c
-- putStrLn "reading statements"
(bs', hs') <-
fmap (bimap concat concat . partitionEithers) $
pooledMapConcurrentlyN threads (bimapM readDhall readDhall) $
(Left <$> bs) ++ (Right <$> hs)
2023-05-13 13:53:43 -04:00
pool <- runNoLoggingT $ mkPool $ sqlConfig config
putStrLn "doing other stuff"
setNumCapabilities 1
2023-05-13 13:53:43 -04:00
handle err $ do
-- _ <- askLoggerIO
-- Get the current DB state.
(state, updates) <- runSqlQueryT pool $ do
2023-05-13 13:53:43 -04:00
runMigration migrateAll
liftIOExceptT $ getDBState config bs' hs'
2023-05-13 13:53:43 -04:00
-- 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.
2023-07-01 13:12:50 -04:00
(rus, is) <-
flip runReaderT state $ do
let (hTs, hSs) = splitHistory hs'
-- TODO for some mysterious reason using multithreading just for this
-- little bit slows the program down by several seconds
-- lift $ setNumCapabilities threads
2023-07-01 13:12:50 -04:00
hSs' <- mapErrorsIO (readHistStmt root) hSs
-- lift $ setNumCapabilities 1
2023-07-06 00:05:16 -04:00
-- lift $ print $ length $ lefts hSs'
-- lift $ print $ length $ rights hSs'
2023-07-01 13:12:50 -04:00
hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
2023-07-06 00:05:16 -04:00
-- lift $ print $ length $ lefts hTs'
bTs <- liftIOExceptT $ mapErrors readBudget bs'
2023-07-06 00:05:16 -04:00
-- lift $ print $ length $ lefts bTs
2023-07-01 13:12:50 -04:00
return $ second concat $ partitionEithers $ hSs' ++ hTs' ++ bTs
2023-07-06 00:05:16 -04:00
-- print $ length $ kmNewCommits state
-- print $ length $ duOldCommits updates
-- print $ length $ duNewTagIds updates
-- print $ length $ duNewAcntPaths updates
-- print $ length $ duNewAcntIds updates
-- print $ length $ duNewCurrencyIds updates
2023-05-13 13:53:43 -04:00
-- Update the DB.
runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
-- NOTE this must come first (unless we defer foreign keys)
updateDBState updates
2023-07-06 00:05:16 -04:00
-- TODO skip this entire section if the database won't change (eg length
-- of 'is' is zero and there are no commits to delete)
2023-07-01 13:12:50 -04:00
res <- runExceptT $ do
-- TODO taking out the hash is dumb
(rs, ues) <- readUpdates $ fmap commitRHash rus
2023-07-06 00:05:16 -04:00
-- rerunnableIO $ print ues
-- rerunnableIO $ print $ length rs
2023-07-01 13:12:50 -04:00
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
2023-01-07 23:41:56 -05:00
-- showBalances
2023-05-29 15:58:27 -04:00
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