pwncash/app/Main.hs

{-# 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.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, ": ", 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
        (liftIO . print) =<< askDBState (M.keys . csAccountMap)
        -- (liftIO . print) =<< askDBState (fmap (accountRFullpath . E.entityVal) . coCreate . csAccounts)
        (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