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 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 . 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 :: 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, updates) <- runSqlQueryT pool $ do
      runMigration migrateAll
      liftIOExceptT $ getDBState 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.
    (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
        hSs' <- mapErrorsIO (readHistStmt root) hSs
        -- lift $ setNumCapabilities 1
        -- lift $ print $ length $ lefts hSs'
        -- lift $ print $ length $ rights hSs'
        hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
        -- lift $ print $ length $ lefts hTs'
        bTs <- liftIOExceptT $ mapErrors readBudget bs'
        -- lift $ print $ length $ lefts bTs
        return $ second concat $ partitionEithers $ 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 updates
      -- TODO skip this entire section if the database won't change (eg length
      -- of 'is' is zero and there are no commits to delete)
      res <- runExceptT $ do
        -- TODO taking out the hash is dumb
        (rs, ues) <- readUpdates $ fmap commitRHash rus
        -- rerunnableIO $ print ues
        -- rerunnableIO $ print $ length rs
        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 = 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