Compare commits

...

18 Commits

Author SHA1 Message Date
Nathan Dwarshuis 09761dabdf FIX actually the multi typo 2024-03-16 20:33:12 -04:00
Nathan Dwarshuis 432aa4f90f FIX multi date pattern bug 2024-03-09 18:07:00 -05:00
Nathan Dwarshuis 26be9212f1 FIX include missing type 2023-10-14 20:28:45 -04:00
Nathan Dwarshuis e8a5088d35 ENH clean up build plan printout 2023-08-19 20:56:40 -04:00
Nathan Dwarshuis 8e2019ac5b ENH skip lines without all fields 2023-08-16 22:24:20 -04:00
Nathan Dwarshuis 4835ab15ca ADD missing defaults 2023-08-16 21:12:11 -04:00
Nathan Dwarshuis d4044dede3 FIX special case type 2023-08-16 21:04:16 -04:00
Nathan Dwarshuis 001ca0ff37 ADD better parsing for statements 2023-08-16 21:01:06 -04:00
Nathan Dwarshuis 2ebfe7a125 FIX sign on income 2023-08-14 20:46:28 -04:00
Nathan Dwarshuis fa41ead348 ENH add inverter to shadow acnt matcher 2023-08-13 23:29:22 -04:00
Nathan Dwarshuis 4fef3714a2 ENH use pattern for shadow matcher accounts 2023-08-13 13:29:38 -04:00
Nathan Dwarshuis 3bf6df3b49 FIX duplicated txs 2023-08-13 12:11:33 -04:00
Nathan Dwarshuis 7609171ab4 FIX failure to track last entry when updating full entrysets 2023-07-27 00:17:53 -04:00
Nathan Dwarshuis 0c5401cd0b Merge branch 'fix_cache' 2023-07-21 23:46:09 -04:00
Nathan Dwarshuis 472b137b9a ENH remove useless field 2023-07-21 23:45:53 -04:00
Nathan Dwarshuis e9772e6516 ENH ensure tx sort order is (kinda) stable 2023-07-21 19:57:54 -04:00
Nathan Dwarshuis bd94afd30f FIX history updates 2023-07-20 00:25:33 -04:00
Nathan Dwarshuis e6f97651e5 Merge branch 'use_subaccount' 2023-07-16 19:57:00 -04:00
9 changed files with 907 additions and 520 deletions

View File

@ -4,18 +4,13 @@ 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
@ -72,7 +67,7 @@ options =
<|> getConf dumpCurrencies
<|> getConf dumpAccounts
<|> getConf dumpAccountKeys
<|> getConf sync
<|> getConf sync_
where
getConf m = Options <$> configFile <*> m
@ -113,8 +108,8 @@ dumpAccountKeys =
<> help "Dump all account keys/aliases"
)
sync :: Parser Mode
sync =
sync_ :: Parser Mode
sync_ =
flag'
Sync
( long "sync"
@ -209,50 +204,14 @@ runDumpAccountKeys c = do
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 _ _ _) <- asks csHistStmts
hSs' <- mapErrorsIO (readHistStmt root) hSs
(CRUDOps hTs _ _ _) <- asks csHistTrans
hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
(CRUDOps bTs _ _ _) <- asks 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 _) <- asks csBudgets
(CRUDOps _ tRs tUs _) <- asks csHistTrans
(CRUDOps _ sRs sUs _) <- asks 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
handle err $ sync pool root config bs' hs'
where
root = takeDirectory c
err (AppException es) = do

View File

@ -278,54 +278,126 @@ let DatePat =
-}
< Cron : CronPat.Type | Mod : ModPat.Type >
let TxOpts_ =
{- Additional metadata to use when parsing a statement -}
let TxAmount1_ =
\(re : Type) ->
{ Type =
{ toDate :
{-
Column title for date
-}
Text
, toAmount :
{-
Column title for amount
-}
Text
, toDesc :
{-
Column title for description
-}
Text
, toOther :
{-
Titles of other columns to include; these will be available in
a map for use in downstream processing (see 'Field')
-}
List Text
, toDateFmt :
{-
Format of the date field as specified in the
Data.Time.Format.formattime Haskell function.
-}
Text
, toAmountFmt :
{- Format of the amount field. Must include three fields for the
sign, numerator, and denominator of the amount.
-}
re
}
, default =
{ toDate = "Date"
, toAmount = "Amount"
, toDesc = "Description"
, toOther = [] : List Text
, toDateFmt = "%0m/%0d/%Y"
, toAmountFmt = "([-+])?([0-9]+)\\.?([0-9]+)?"
}
{ a1Column : Text
, a1Fmt :
{-
Format of the amount field. Must include three fields for the
sign, numerator, and denominator of the amount.
-}
re
}
let TxOpts = TxOpts_ Text
let TxAmount1 =
{ Type = TxAmount1_ Text
, default = { a1Column = "Amount", a1Fmt = "([-+])?([0-9\\.]+)" }
}
let TxAmount2_ =
\(re : Type) ->
{ a2Positive : Text
, a2Negative : Text
, a2Fmt :
{-
Format of the amount field. Must include two fields for the
numerator and denominator of the amount.
-}
re
}
let TxAmount2 =
{ Type = TxAmount2_ Text
, default =
{ a2Positive = "Deposit"
, a2Negative = "Withdraw"
, a2Fmt = "([0-9\\.]+)"
}
}
let TxAmountSpec_ =
\(re : Type) ->
< AmountSingle : TxAmount1_ re | AmountDual : TxAmount2_ re >
let TxOpts_ =
{-
Additional metadata to use when parsing a statement
-}
\(re : Type) ->
{ toDate :
{-
Column title for date
-}
Text
, toAmount :
{-
Column title for amount
-}
TxAmountSpec_ re
, toDesc :
{-
Column title for description
-}
Text
, toOther :
{-
Titles of other columns to include; these will be available in
a map for use in downstream processing (see 'Field')
-}
List Text
, toDateFmt :
{-
Format of the date field as specified in the
Data.Time.Format.formattime Haskell function.
-}
Text
, toSkipBlankDate :
{-
Skip line if date field is a blank
-}
Bool
, toSkipBlankAmount :
{-
Skip line if amount field(s) is(are) a blank
-}
Bool
, toSkipBlankDescription :
{-
Skip line if description field is a blank
-}
Bool
, toSkipBlankOther :
{-
Skip line if any arbitrary fields are blank (these fields must also
be listed in 'toOther' to be considered)
-}
List Text
, toSkipMissingFields :
{-
Skip line if any fields are missing (this is different from blank;
'missing' means there is no field with name 'X', 'blank' means that
there is a field 'X' and its value is an empty string)
-}
Bool
}
let TxAmountSpec = TxAmountSpec_ Text
let TxOpts =
{ Type = TxOpts_ Text
, default =
{ toDate = "Date"
, toAmount = TxAmountSpec.AmountSingle TxAmount1::{=}
, toDesc = "Description"
, toOther = [] : List Text
, toDateFmt = "%0m/%0d/%Y"
, toSkipBlankDate = False
, toSkipBlankAmount = False
, toSkipBlankDescription = False
, toSkipBlankOther = [] : List Text
, toSkipMissingFields = False
}
}
let Field =
{-
@ -984,54 +1056,40 @@ let Income =
}
}
let AcntSet =
let AcntMatcher_ =
{-
A list of account IDs represented as a set.
Regex pattern by which matching account ids will be identified
-}
{ Type =
{ asList : List AcntID
, asInclude :
{-
If true, tests for account membership in this set will return
true if the account is in the set. Invert this behavior otherwise.
-}
Bool
}
, default = { asList = [] : List AcntID, asInclude = False }
}
\(re : Type) ->
{ Type = { amPat : re, amInvert : Bool }, default.amInvert = False }
let TransferMatcher =
let AcntMatcher = AcntMatcher_ Text
let TransferMatcher_ =
{-
Means to match a transfer (which will be used to "clone" it in some
fashion)
-}
{ Type =
{ tmFrom :
{-
List of accounts (which may be empty) to match with the
starting account in a transfer.
-}
AcntSet.Type
, tmTo :
{-
List of accounts (which may be empty) to match with the
ending account in a transfer.
-}
AcntSet.Type
, tmDate :
{-
If given, means to match the date of a transfer.
-}
Optional DateMatcher
, tmVal :
{-
If given, means to match the value of a transfer.
-}
ValMatcher.Type
}
\(re : Type) ->
{ tmFrom : Optional (AcntMatcher_ re).Type
, tmTo : Optional (AcntMatcher_ re).Type
, tmDate :
{-
If given, means to match the date of a transfer.
-}
Optional DateMatcher
, tmVal :
{-
If given, means to match the value of a transfer.
-}
ValMatcher.Type
}
let TransferMatcher =
{ Type = TransferMatcher_ Text
, default =
{ tmFrom = AcntSet.default
, tmTo = AcntSet.default
{ tmFrom = None AcntMatcher.Type
, tmTo = None AcntMatcher.Type
, tmDate = None DateMatcher
, tmVal = ValMatcher.default
}
@ -1069,7 +1127,6 @@ let ShadowTransfer =
specified in other fields of this type.
-}
TransferMatcher.Type
, stType : TransferType
, stRatio :
{-
Fixed multipler to translate value of matched transfer to this one.
@ -1149,9 +1206,9 @@ in { CurID
, Budget
, Allocation
, Amount
, TransferMatcher_
, TransferMatcher
, ShadowTransfer
, AcntSet
, TaggedAcnt
, AccountTree
, Account
@ -1178,4 +1235,13 @@ in { CurID
, TransferAmount
, MultiAlloAmount
, SingleAlloAmount
, AcntMatcher_
, AcntMatcher
, TxAmountSpec
, TxAmountSpec_
, TxAmount1_
, TxAmount2_
, TxAmount1
, TxAmount2
, BudgetTransfer
}

View File

@ -1,4 +1,4 @@
module Internal.Budget (readBudget) where
module Internal.Budget (readBudgetCRUD) where
import Control.Monad.Except
import Data.Decimal hiding (allocate)
@ -13,7 +13,12 @@ import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T
import RIO.Time
readBudget :: (MonadAppError m, MonadFinance m) => Budget -> m [Tx CommitR]
readBudgetCRUD :: (MonadAppError m, MonadFinance m) => PreBudgetCRUD -> m FinalBudgetCRUD
readBudgetCRUD o@CRUDOps {coCreate} = do
bs <- mapM readBudget coCreate
return $ o {coCreate = bs}
readBudget :: (MonadAppError m, MonadFinance m) => Budget -> m (BudgetName, [Tx CommitR])
readBudget
b@Budget
{ bgtLabel
@ -27,15 +32,14 @@ readBudget
} =
do
spanRes <- getSpan
case spanRes of
(bgtLabel,) <$> case spanRes of
Nothing -> return []
Just budgetSpan -> do
(intAllos, _) <- combineError intAlloRes acntRes (,)
let res1 = mapErrors (readIncome c bgtLabel intAllos budgetSpan) bgtIncomes
let res2 = expandTransfers c bgtLabel budgetSpan bgtTransfers
txs <- combineError (concat <$> res1) res2 (++)
shadow <- addShadowTransfers bgtShadowTransfers txs
return $ txs ++ shadow
let res1 = mapErrors (readIncome c intAllos budgetSpan) bgtIncomes
let res2 = expandTransfers c budgetSpan bgtTransfers
combineErrorM (concat <$> res1) res2 $ \is ts ->
addShadowTransfers bgtShadowTransfers (is ++ ts)
where
c = CommitR (CommitHash $ hash b) CTBudget
acntRes = mapErrors isNotIncomeAcnt alloAcnts
@ -49,7 +53,7 @@ readBudget
++ (alloAcnt <$> bgtTax)
++ (alloAcnt <$> bgtPosttax)
getSpan = do
globalSpan <- asks (unBSpan . csBudgetScope)
globalSpan <- asks (unBSpan . tsBudgetScope)
case bgtInterval of
Nothing -> return $ Just globalSpan
Just bi -> do
@ -78,14 +82,12 @@ sortAllo a@Allocation {alloAmts = as} = do
readIncome
:: (MonadAppError m, MonadFinance m)
=> CommitR
-> BudgetName
-> IntAllocations
-> DaySpan
-> Income
-> m [Tx CommitR]
readIncome
key
name
(intPre, intTax, intPost)
ds
Income
@ -143,20 +145,16 @@ readIncome
let allos = allo2Trans <$> (pre ++ tax ++ post)
let primary =
EntrySet
{ esTotalValue = gross
{ esTotalValue = -gross
, esCurrency = cpID cp
, esFrom = HalfEntrySet {hesPrimary = src, hesOther = []}
, esTo = HalfEntrySet {hesPrimary = dest, hesOther = allos}
}
return $
Tx
{ txCommit = key
, txDate = day
{ txMeta = TxMeta day incPriority (TxDesc "") key
, txPrimary = Left primary
, txOther = []
, txDescr = TxDesc ""
, txBudget = name
, txPriority = incPriority
}
periodScaler
@ -347,33 +345,55 @@ fromShadow
-> ShadowTransfer
-> m (Maybe ShadowEntrySet)
fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} =
combineErrorM curRes shaRes $ \cur sha -> do
combineErrorM curRes mRes $ \cur compiled -> do
res <- liftExcept $ shadowMatches compiled tx
let es = entryPair stFrom stTo cur stDesc stRatio ()
return $ if not sha then Nothing else Just es
return $ if not res then Nothing else Just es
where
curRes = lookupCurrencyKey (CurID stCurrency)
shaRes = liftExcept $ shadowMatches stMatch tx
curRes = lookupCurrencyKey stCurrency
mRes = liftExcept $ compileMatch stMatch
shadowMatches :: TransferMatcher -> Tx CommitR -> AppExcept Bool
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDate} = do
-- NOTE this will only match against the primary entry set since those
-- are what are guaranteed to exist from a transfer
valRes <- case txPrimary of
Left es -> valMatches tmVal $ toRational $ esTotalValue es
Right _ -> return True
return $
memberMaybe fa tmFrom
&& memberMaybe ta tmTo
&& maybe True (`dateMatches` txDate) tmDate
&& valRes
shadowMatches :: TransferMatcherRe -> Tx CommitR -> AppExcept Bool
shadowMatches
TransferMatcher_ {tmFrom, tmTo, tmDate, tmVal}
Tx {txPrimary, txMeta = TxMeta {txmDate}} =
do
-- ASSUME these will never fail and thus I don't need to worry about
-- stacking the errors
fromRes <- acntMatches fa tmFrom
toRes <- acntMatches ta tmTo
-- NOTE this will only match against the primary entry set since those
-- are what are guaranteed to exist from a transfer
valRes <- case txPrimary of
Left es -> valMatches tmVal $ toRational $ esTotalValue es
Right _ -> return True
return $
fromRes
&& toRes
&& maybe True (`dateMatches` txmDate) tmDate
&& valRes
where
fa = either getAcntFrom getAcntFrom txPrimary
ta = either getAcntTo getAcntTo txPrimary
getAcntFrom = getAcnt esFrom
getAcntTo = getAcnt esTo
getAcnt f = eAcnt . hesPrimary . f
acntMatches (AcntID a) = maybe (return True) (match' a)
match' a AcntMatcher_ {amPat, amInvert} =
(if amInvert then not else id) <$> matchMaybe a amPat
compileMatch :: TransferMatcher_ T.Text -> AppExcept TransferMatcherRe
compileMatch m@TransferMatcher_ {tmTo, tmFrom} =
combineError tres fres $ \t f -> m {tmTo = t, tmFrom = f}
where
fa = either getAcntFrom getAcntFrom txPrimary
ta = either getAcntTo getAcntTo txPrimary
getAcntFrom = getAcnt esFrom
getAcntTo = getAcnt esTo
getAcnt f = eAcnt . hesPrimary . f
memberMaybe x AcntSet {asList, asInclude} =
(if asInclude then id else not) $ x `elem` (AcntID <$> asList)
go a@AcntMatcher_ {amPat} = do
(_, p) <- compileRegex False amPat
return $ a {amPat = p}
tres = mapM go tmTo
fres = mapM go tmFrom
-- memberMaybe x AcntSet {asList, asInclude} =
-- (if asInclude then id else not) $ x `elem` (AcntID <$> asList)
--------------------------------------------------------------------------------
-- random

View File

@ -1,8 +1,9 @@
module Internal.Database
( runDB
, readConfigState
, readDB
, nukeTables
, updateDBState
, updateMeta
-- , updateDBState
, tree2Records
, flattenAcntRoot
, indexAcntRoot
@ -10,16 +11,18 @@ module Internal.Database
, mkPool
, insertEntry
, readUpdates
, insertAll
, updateTx
, sync
)
where
import Conduit
import Control.Monad.Except
import Control.Monad.IO.Rerunnable
import Control.Monad.Logger
import Data.Decimal
import Data.Hashable
import qualified Data.Text.IO as TI
import Database.Esqueleto.Experimental ((:&) (..), (==.), (?.), (^.))
import qualified Database.Esqueleto.Experimental as E
import Database.Esqueleto.Internal.Internal (SqlSelect)
@ -36,16 +39,84 @@ import Database.Persist.Sqlite hiding
, (==.)
, (||.)
)
import GHC.Err
import Internal.Budget
import Internal.History
import Internal.Types.Main
import Internal.Utils
import RIO hiding (LogFunc, isNothing, on, (^.))
import RIO hiding (LogFunc, isNothing, logDebug, on, (^.))
import qualified RIO.List as L
import qualified RIO.Map as M
import qualified RIO.NonEmpty as NE
import qualified RIO.Set as S
import qualified RIO.Text as T
sync
:: (MonadUnliftIO m, MonadRerunnableIO m)
=> ConnectionPool
-> FilePath
-> Config
-> [Budget]
-> [History]
-> m ()
sync pool root c bs hs = do
-- _ <- askLoggerIO
(meta, txState, budgets, history) <- runSqlQueryT pool $ do
runMigration migrateAll
liftIOExceptT $ readDB c 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.
(budgets', history') <-
flip runReaderT txState $ do
-- TODO collect errors here
b <- liftIOExceptT $ readBudgetCRUD budgets
h <- readHistoryCRUD root history
return (b, h)
liftIO $ TI.putStr $ formatBuildPlan history budgets
-- Update the DB.
runSqlQueryT pool $ withTransaction $ flip runReaderT txState $ do
-- NOTE this must come first (unless we defer foreign keys)
updateMeta meta
res <- runExceptT $ do
-- TODO multithread this :)
insertBudgets budgets'
insertHistory history'
-- 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
formatBuildPlan :: PreHistoryCRUD -> PreBudgetCRUD -> T.Text
formatBuildPlan
CRUDOps {coCreate = hc, coRead = hr, coUpdate = hu, coDelete = hd}
CRUDOps {coCreate = bc, coDelete = bd} =
T.unlines $ "Build plan:" : (T.append " " <$> ht ++ [""] ++ bt)
where
ht =
[ T.append "History transfers to create: " $ tshow hCt
, T.append "History statements to create: " $ tshow hCs
, T.append "History entries to read: " $ tshow $ length hr
, T.append "History entry sets to update: " $ tshow $ length hu
]
++ formatDel "History" hd
bt =
T.append "Budgets to create: " (tshow $ bgtLabel <$> bc)
: formatDel "Budget" bd
toDel what thing n = T.unwords [what, thing, "to delete:", tshow n]
formatDel what (DeleteTxs e a b c' d) =
[ f "commits" e
, f "transactions" a
, f "entry sets" b
, f "entries" c'
, f "tag relations" d
]
where
f :: T.Text -> [a] -> T.Text
f thing = toDel what thing . length
(hCt, hCs) = bimap length length hc
runDB
:: MonadUnliftIO m
=> SqlConfig
@ -106,58 +177,116 @@ nukeTables = do
-- toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name]
-- toBal = maybe "???" (fmtRational 2) . unValue
readConfigState
readDB
:: (MonadAppError m, MonadSqlQuery m)
=> Config
-> [Budget]
-> [History]
-> m ConfigState
readConfigState c bs hs = do
(acnts2Ins, acntsRem, acnts2Del) <- diff newAcnts
(pathsIns, _, pathsDel) <- diff newPaths
(curs2Ins, cursRem, curs2Del) <- diff newCurs
(tags2Ins, tagsRem, tags2Del) <- diff newTags
let amap = makeAcntMap $ acnts2Ins ++ (fst <$> acntsRem)
let cmap = currencyMap $ curs2Ins ++ (fst <$> cursRem)
let tmap = makeTagMap $ tags2Ins ++ (fst <$> tagsRem)
let fromMap f = S.fromList . fmap f . M.elems
let existing =
ExistingConfig (fromMap fst amap) (fromMap id tmap) (fromMap cpID cmap)
-> m (MetaCRUD, TxState, PreBudgetCRUD, PreHistoryCRUD)
readDB c bs hs = do
curAcnts <- readCurrentIds
curPaths <- readCurrentIds
curCurs <- readCurrentIds
curTags <- readCurrentIds
(curBgts, curHistTrs, curHistSts) <- readCurrentCommits
-- TODO refine this test to include the whole db (with data already mixed
-- in this algorithm)
let bsRes = BudgetSpan <$> resolveScope budgetInterval
let hsRes = HistorySpan <$> resolveScope statementInterval
combineErrorM bsRes hsRes $ \bscope hscope -> do
let dbempty = null $ curBgts ++ curHistTrs ++ curHistSts
-- ASSUME the db must be empty if these are empty
let dbempty = null curAcnts && null curCurs && null curTags
let meta =
MetaCRUD
{ mcCurrencies = makeCD newCurs curCurs
, mcTags = makeCD newTags curTags
, mcAccounts = makeCD newAcnts curAcnts
, mcPaths = makeCD newPaths curPaths
, mcBudgetScope = bscope
, mcHistoryScope = hscope
}
let txS =
TxState
{ tsAccountMap = amap
, tsCurrencyMap = cmap
, tsTagMap = tmap
, tsBudgetScope = bscope
, tsHistoryScope = hscope
}
(bChanged, hChanged) <- readScopeChanged dbempty bscope hscope
bgt <- makeTxCRUD existing bs curBgts bChanged
hTrans <- makeTxCRUD existing ts curHistTrs hChanged
hStmt <- makeTxCRUD existing ss curHistSts hChanged
return $
ConfigState
{ csCurrencies = CRUDOps curs2Ins () () curs2Del
, csTags = CRUDOps tags2Ins () () tags2Del
, csAccounts = CRUDOps acnts2Ins () () acnts2Del
, csPaths = CRUDOps pathsIns () () pathsDel
, csBudgets = bgt
, csHistTrans = hTrans
, csHistStmts = hStmt
, csAccountMap = amap
, csCurrencyMap = cmap
, csTagMap = tmap
, csBudgetScope = bscope
, csHistoryScope = hscope
}
budgets <- makeBudgetCRUD existing bs curBgts bChanged
history <- makeStatementCRUD existing (ts, curHistTrs) (ss, curHistSts) hChanged
return (meta, txS, budgets, history)
where
(ts, ss) = splitHistory hs
diff new = setDiffWith (\a b -> E.entityKey a == b) new <$> readCurrentIds
makeCD new old =
let (cs, _, ds) = setDiffWith (\a b -> E.entityKey a == b) new old
in CRUDOps cs () () ds
(newAcnts, newPaths) = indexAcntRoot $ accounts c
newTags = tag2Record <$> tags c
newCurs = currency2Record <$> currencies c
resolveScope f = liftExcept $ resolveDaySpan $ f $ scope c
amap = makeAcntMap newAcnts
cmap = currencyMap newCurs
tmap = makeTagMap newTags
fromMap f = S.fromList . fmap f . M.elems
existing = ExistingConfig (fromMap fst amap) (fromMap id tmap) (fromMap cpID cmap)
makeBudgetCRUD
:: MonadSqlQuery m
=> ExistingConfig
-> [Budget]
-> [CommitHash]
-> Bool
-> m (CRUDOps [Budget] () () DeleteTxs)
makeBudgetCRUD existing new old scopeChanged = do
(toIns, toDel) <-
if scopeChanged
then (new,) <$> readTxIds old
else do
let (toDelHashes, overlap, toIns) = setDiffHashes old new
toDel <- readTxIds toDelHashes
(toInsRetry, _) <- readInvalidIds existing overlap
return (toIns ++ (snd <$> toInsRetry), toDel)
return $ CRUDOps toIns () () toDel
makeStatementCRUD
:: (MonadAppError m, MonadSqlQuery m)
=> ExistingConfig
-> ([PairedTransfer], [CommitHash])
-> ([Statement], [CommitHash])
-> Bool
-> m
( CRUDOps
([PairedTransfer], [Statement])
[ReadEntry]
[Either TotalUpdateEntrySet FullUpdateEntrySet]
DeleteTxs
)
makeStatementCRUD existing ts ss scopeChanged = do
(toInsTs, toDelTs, validTs) <- uncurry diff ts
(toInsSs, toDelSs, validSs) <- uncurry diff ss
let toDelAllHashes = toDelTs ++ toDelSs
-- If we are inserting or deleting something or the scope changed, pull out
-- the remainder of the entries to update/read as we are (re)inserting other
-- stuff (this is necessary because a given transaction may depend on the
-- value of previous transactions, even if they are already in the DB).
(toRead, toUpdate) <- case (toInsTs, toInsSs, toDelAllHashes, scopeChanged) of
([], [], [], False) -> return ([], [])
_ -> readUpdates $ validTs ++ validSs
toDelAll <- readTxIds toDelAllHashes
return $ CRUDOps (toInsTs, toInsSs) toRead toUpdate toDelAll
where
diff :: (MonadSqlQuery m, Hashable a) => [a] -> [CommitHash] -> m ([a], [CommitHash], [CommitHash])
diff new old = do
let (toDelHashes, overlap, toIns) = setDiffHashes old new
-- Check the overlap for rows with accounts/tags/currencies that
-- won't exist on the next update. Those with invalid IDs will be set aside
-- to delete and reinsert (which may also fail) later
(invalid, valid) <- readInvalidIds existing overlap
let (toDelAllHashes, toInsAll) = bimap (toDelHashes ++) (toIns ++) $ L.unzip invalid
return (toInsAll, toDelAllHashes, valid)
setDiffHashes :: Hashable a => [CommitHash] -> [a] -> ([CommitHash], [(CommitHash, a)], [a])
setDiffHashes = setDiffWith (\a b -> CommitHash (hash b) == a)
readScopeChanged
:: (MonadAppError m, MonadSqlQuery m)
@ -175,37 +304,6 @@ readScopeChanged dbempty bscope hscope = do
return (bscope /= b, hscope /= h)
_ -> throwAppError $ DBError DBMultiScope
makeTxCRUD
:: (MonadAppError m, MonadSqlQuery m, Hashable a)
=> ExistingConfig
-> [a]
-> [CommitHash]
-> Bool
-> m
( CRUDOps
[a]
[ReadEntry]
[Either TotalUpdateEntrySet FullUpdateEntrySet]
DeleteTxs
)
makeTxCRUD existing newThings curThings scopeChanged = do
let (toDelHashes, overlap, toIns) =
setDiffWith (\a b -> hash b == unCommitHash a) curThings newThings
-- Check the overlap for rows with accounts/tags/currencies that
-- won't exist on the next update. Those with invalid IDs will be set aside
-- to delete and reinsert (which may also fail) later
(noRetry, toInsRetry) <- readInvalidIds existing overlap
let (toDelAllHashes, toInsAll) = bimap (toDelHashes ++) (toIns ++) $ L.unzip toInsRetry
-- If we are inserting or deleting something or the scope changed, pull out
-- the remainder of the entries to update/read as we are (re)inserting other
-- stuff (this is necessary because a given transaction may depend on the
-- value of previous transactions, even if they are already in the DB).
(toRead, toUpdate) <- case (toInsAll, toDelAllHashes, scopeChanged) of
([], [], False) -> return ([], [])
_ -> readUpdates noRetry
toDelAll <- readTxIds toDelAllHashes
return $ CRUDOps toInsAll toRead toUpdate toDelAll
readTxIds :: MonadSqlQuery m => [CommitHash] -> m DeleteTxs
readTxIds cs = do
xs <- selectE $ do
@ -218,33 +316,29 @@ readTxIds cs = do
`E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
`E.innerJoin` E.table
`E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
`E.innerJoin` E.table
`E.on` (\(_ :& _ :& _ :& e :& t) -> e ^. EntryRId ==. t ^. TagRelationREntry)
`E.leftJoin` E.table
`E.on` (\(_ :& _ :& _ :& e :& t) -> E.just (e ^. EntryRId) ==. t ?. TagRelationREntry)
E.where_ $ commits ^. CommitRHash `E.in_` E.valList cs
return
( txs ^. TransactionRId
( commits ^. CommitRId
, txs ^. TransactionRId
, ess ^. EntrySetRId
, es ^. EntryRId
, ts ^. TagRelationRId
, ts ?. TagRelationRId
)
let (txs, ss, es, ts) = L.unzip4 xs
let (cms, txs, ss, es, ts) = L.unzip5 xs
return $
DeleteTxs
{ dtTxs = go txs
{ dtCommits = go cms
, dtTxs = go txs
, dtEntrySets = go ss
, dtEntries = go es
, dtTagRelations = E.unValue <$> ts
, dtTagRelations = catMaybes $ E.unValue <$> ts
}
where
go :: Eq a => [E.Value a] -> [a]
go = fmap (E.unValue . NE.head) . NE.group
splitHistory :: [History] -> ([PairedTransfer], [Statement])
splitHistory = partitionEithers . fmap go
where
go (HistTransfer x) = Left x
go (HistStatement x) = Right x
makeTagMap :: [Entity TagR] -> TagMap
makeTagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
@ -255,7 +349,7 @@ currency2Record :: Currency -> Entity CurrencyR
currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
Entity (toKey c) $ CurrencyR (CurID curSymbol) curFullname (fromIntegral curPrecision)
readCurrentIds :: PersistEntity a => MonadSqlQuery m => m [Key a]
readCurrentIds :: (PersistEntity a, MonadSqlQuery m) => m [Key a]
readCurrentIds = fmap (E.unValue <$>) $ selectE $ do
rs <- E.from E.table
return (rs ^. E.persistIdField)
@ -263,8 +357,8 @@ readCurrentIds = fmap (E.unValue <$>) $ selectE $ do
readCurrentCommits :: MonadSqlQuery m => m ([CommitHash], [CommitHash], [CommitHash])
readCurrentCommits = do
xs <- selectE $ do
rs <- E.from E.table
return (rs ^. CommitRHash, rs ^. CommitRType)
commits <- E.from E.table
return (commits ^. CommitRHash, commits ^. CommitRType)
return $ foldr go ([], [], []) xs
where
go (x, t) (bs, ts, hs) =
@ -387,39 +481,55 @@ indexAcntRoot = bimap concat concat . L.unzip . fmap (uncurry tree2Records) . fl
updateCD
:: ( MonadSqlQuery m
, PersistRecordBackend a SqlBackend
, PersistRecordBackend b SqlBackend
)
=> CDOps (Entity a) (Key b)
=> EntityCRUDOps a
-> m ()
updateCD (CRUDOps cs () () ds) = do
mapM_ deleteKeyE ds
insertEntityManyE cs
-- TODO defer foreign keys so I don't need to confusingly reverse this stuff
deleteTxs :: MonadSqlQuery m => DeleteTxs -> m ()
deleteTxs DeleteTxs {dtTxs, dtEntrySets, dtEntries, dtTagRelations} = do
mapM_ deleteKeyE dtTxs
mapM_ deleteKeyE dtEntrySets
mapM_ deleteKeyE dtEntries
deleteTxs DeleteTxs {dtTxs, dtEntrySets, dtEntries, dtTagRelations, dtCommits} = do
mapM_ deleteKeyE dtTagRelations
mapM_ deleteKeyE dtEntries
mapM_ deleteKeyE dtEntrySets
mapM_ deleteKeyE dtTxs
mapM_ deleteKeyE dtCommits
updateDBState :: (MonadFinance m, MonadSqlQuery m) => m ()
updateDBState = do
updateCD =<< asks csCurrencies
updateCD =<< asks csAccounts
updateCD =<< asks csPaths
updateCD =<< asks csTags
deleteTxs =<< asks (coDelete . csBudgets)
deleteTxs =<< asks (coDelete . csHistTrans)
deleteTxs =<< asks (coDelete . csHistStmts)
b <- asks csBudgetScope
h <- asks csHistoryScope
repsertE (E.toSqlKey 1) $ ConfigStateR h b
-- updateDBState :: (MonadFinance m, MonadSqlQuery m) => m ()
-- updateDBState = do
-- updateCD =<< asks csCurrencies
-- updateCD =<< asks csAccounts
-- updateCD =<< asks csPaths
-- updateCD =<< asks csTags
-- -- deleteTxs =<< asks (coDelete . csBudgets)
-- -- deleteTxs =<< asks (coDelete . csHistory)
-- b <- asks csBudgetScope
-- h <- asks csHistoryScope
-- repsertE (E.toSqlKey 1) $ ConfigStateR h b
updateMeta :: MonadSqlQuery m => MetaCRUD -> m ()
updateMeta
MetaCRUD
{ mcCurrencies
, mcAccounts
, mcPaths
, mcTags
, mcBudgetScope
, mcHistoryScope
} = do
updateCD mcCurrencies
updateCD mcAccounts
updateCD mcPaths
updateCD mcTags
repsertE (E.toSqlKey 1) $ ConfigStateR mcHistoryScope mcBudgetScope
readInvalidIds
:: MonadSqlQuery m
=> ExistingConfig
-> [(CommitHash, a)]
-> m ([CommitHash], [(CommitHash, a)])
-> m ([(CommitHash, a)], [CommitHash])
readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
rs <- selectE $ do
(commits :& _ :& entrysets :& entries :& tags) <-
@ -444,14 +554,13 @@ readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
let cs = go ecCurrencies $ fmap (\(i, E.Value c, _, _) -> (i, c)) rs
let as = go ecAccounts $ fmap (\(i, _, E.Value a, _) -> (i, a)) rs
let ts = go ecTags [(i, t) | (i, _, _, E.Value (Just t)) <- rs]
let valid = (cs `S.intersection` as) `S.intersection` ts
let (a0, _) = first (fst <$>) $ L.partition ((`S.member` valid) . fst) xs
return (a0, [])
let invalid = (cs `S.union` as) `S.union` ts
return $ second (fst <$>) $ L.partition ((`S.member` invalid) . fst) xs
where
go existing =
S.fromList
. fmap (E.unValue . fst)
. L.filter (all (`S.member` existing) . snd)
. L.filter (not . all (`S.member` existing) . snd)
. groupKey id
readUpdates
@ -477,9 +586,10 @@ readUpdates hashes = do
,
(
( entrysets ^. EntrySetRId
, entrysets ^. EntrySetRIndex
, txs ^. TransactionRDate
, txs ^. TransactionRBudgetName
, txs ^. TransactionRPriority
, txs ^. TransactionRDescription
,
( entrysets ^. EntrySetRCurrency
, currencies ^. CurrencyRPrecision
@ -489,11 +599,12 @@ readUpdates hashes = do
)
)
let (toUpdate, toRead) = L.partition (E.unValue . fst) xs
toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _, _) -> i) (snd <$> toUpdate)
toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _, _, _) -> i) (snd <$> toUpdate)
let toRead' = fmap (makeRE . snd) toRead
return (toRead', toUpdate')
where
makeUES ((_, day, name, pri, (curID, prec)), es) = do
makeUES ((_, esi, day, pri, desc, (curID, prec)), es) = do
let sk = TxSortKey (E.unValue day) (E.unValue pri) (E.unValue desc)
let prec' = fromIntegral $ E.unValue prec
let cur = E.unValue curID
let res =
@ -511,8 +622,7 @@ readUpdates hashes = do
Left x ->
Left $
UpdateEntrySet
{ utDate = E.unValue day
, utCurrency = cur
{ utCurrency = cur
, utFrom0 = x
, utTo0 = to0
, utFromRO = fromRO
@ -520,14 +630,13 @@ readUpdates hashes = do
, utFromUnk = fromUnk
, utToUnk = toUnk
, utTotalValue = realFracToDecimalP prec' tot
, utBudget = E.unValue name
, utPriority = E.unValue pri
, utSortKey = sk
, utIndex = E.unValue esi
}
Right x ->
Right $
UpdateEntrySet
{ utDate = E.unValue day
, utCurrency = cur
{ utCurrency = cur
, utFrom0 = x
, utTo0 = to0
, utFromRO = fromRO
@ -535,20 +644,20 @@ readUpdates hashes = do
, utFromUnk = fromUnk
, utToUnk = toUnk
, utTotalValue = ()
, utBudget = E.unValue name
, utPriority = E.unValue pri
, utSortKey = sk
, utIndex = E.unValue esi
}
-- TODO this error is lame
_ -> throwAppError $ DBError $ DBUpdateUnbalanced
makeRE ((_, day, name, pri, (curID, prec)), entry) = do
_ -> throwAppError $ DBError DBUpdateUnbalanced
makeRE ((_, esi, day, pri, desc, (curID, prec)), entry) = do
let e = entityVal entry
in ReadEntry
{ reDate = E.unValue day
, reCurrency = E.unValue curID
{ reCurrency = E.unValue curID
, reAcnt = entryRAccount e
, reValue = realFracToDecimal (fromIntegral $ E.unValue prec) (entryRValue e)
, reBudget = E.unValue name
, rePriority = E.unValue pri
, reSortKey = TxSortKey (E.unValue day) (E.unValue pri) (E.unValue desc)
, reESIndex = E.unValue esi
, reIndex = entryRIndex e
}
splitFrom
@ -665,8 +774,8 @@ readDeferredValue prec (k, e) = case (entryRCachedValue e, entryRCachedType e) o
(Nothing, Nothing) -> return $ Left $ makeUnkUE k e
(Just v, Nothing) -> err $ DBLinkInvalidValue v False
(Just v, Just TFixed) -> err $ DBLinkInvalidValue v True
(Nothing, Just TBalance) -> err $ DBLinkInvalidBalance
(Nothing, Just TPercent) -> err $ DBLinkInvalidPercent
(Nothing, Just TBalance) -> err DBLinkInvalidBalance
(Nothing, Just TPercent) -> err DBLinkInvalidPercent
where
go = return . Right . Right
err = throwAppError . DBError . DBLinkError k
@ -680,21 +789,72 @@ makeRoUE prec e = makeUE () e $ StaticValue (realFracToDecimalP prec $ entryRVal
makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
makeUnkUE k e = makeUE k e ()
insertAll
-- updateEntries
-- :: (MonadSqlQuery m, MonadFinance m, MonadRerunnableIO m)
-- => [ ( BudgetName
-- , CRUDOps
-- [Tx CommitR]
-- [ReadEntry]
-- [(Either TotalUpdateEntrySet FullUpdateEntrySet)]
-- DeleteTxs
-- )
-- ]
-- -> m ()
-- updateEntries es = do
-- res <- runExceptT $ mapErrors (uncurry insertAll) es
-- void $ rerunnableIO $ fromEither res
insertBudgets
:: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
=> [EntryCRU]
=> FinalBudgetCRUD
-> m ()
insertAll ebs = do
(toUpdate, toInsert) <- balanceTxs ebs
insertBudgets (CRUDOps bs () () ds) = do
deleteTxs ds
mapM_ go bs
where
go (name, cs) = do
-- TODO useless overhead?
(toUpdate, toInsert) <- balanceTxs (ToInsert <$> cs)
mapM_ updateTx toUpdate
forM_ (groupWith (txmCommit . itxMeta) toInsert) $
\(c, ts) -> do
ck <- insert c
mapM_ (insertTx name ck) ts
insertHistory
:: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
=> FinalHistoryCRUD
-> m ()
insertHistory (CRUDOps cs rs us ds) = do
(toUpdate, toInsert) <- balanceTxs $ (ToInsert <$> cs) ++ (ToRead <$> rs) ++ (ToUpdate <$> us)
mapM_ updateTx toUpdate
forM_ (groupWith itxCommit toInsert) $
forM_ (groupWith (txmCommit . itxMeta) toInsert) $
\(c, ts) -> do
ck <- insert c
mapM_ (insertTx ck) ts
mapM_ (insertTx historyName ck) ts
deleteTxs ds
insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget, itxPriority} = do
k <- insert $ TransactionR c itxDate itxDescr itxBudget itxPriority
-- insertAll
-- :: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
-- => BudgetName
-- -> CRUDOps
-- [Tx CommitR]
-- [ReadEntry]
-- [Either TotalUpdateEntrySet FullUpdateEntrySet]
-- DeleteTxs
-- -> m ()
-- insertAll b (CRUDOps cs rs us ds) = do
-- (toUpdate, toInsert) <- balanceTxs $ (ToInsert <$> cs) ++ (ToRead <$> rs) ++ (ToUpdate <$> us)
-- mapM_ updateTx toUpdate
-- forM_ (groupWith itxCommit toInsert) $
-- \(c, ts) -> do
-- ck <- insert c
-- mapM_ (insertTx b ck) ts
-- deleteTxs ds
insertTx :: MonadSqlQuery m => BudgetName -> CommitRId -> InsertTx -> m ()
insertTx b c InsertTx {itxMeta = TxMeta {txmDate, txmPriority, txmDesc}, itxEntrySets} = do
k <- insert $ TransactionR c txmDate b txmDesc txmPriority
mapM_ (uncurry (insertEntrySet k)) $ zip [0 ..] (NE.toList itxEntrySets)
where
insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do
@ -740,3 +900,6 @@ deleteKeyE q = unsafeLiftSql "esqueleto-deleteKey" (E.deleteKey q)
insertEntityManyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => [Entity a] -> m ()
insertEntityManyE q = unsafeLiftSql "esqueleto-insertEntityMany" (E.insertEntityMany q)
historyName :: BudgetName
historyName = BudgetName "history"

View File

@ -2,6 +2,7 @@ module Internal.History
( readHistStmt
, readHistTransfer
, splitHistory
, readHistoryCRUD
)
where
@ -22,7 +23,20 @@ import qualified RIO.Text as T
import RIO.Time
import qualified RIO.Vector as V
import Text.Regex.TDFA hiding (matchAll)
import Text.Regex.TDFA.Text
readHistoryCRUD
:: (MonadUnliftIO m, MonadFinance m)
=> FilePath
-> PreHistoryCRUD
-> m FinalHistoryCRUD
readHistoryCRUD root o@CRUDOps {coCreate = (ts, ss)} = do
-- TODO multithread this for some extra fun :)
ss' <- mapErrorsIO (readHistStmt root) ss
fromEitherM $ runExceptT $ do
let sRes = mapErrors (ExceptT . return) ss'
let tRes = mapErrors readHistTransfer ts
combineError sRes tRes $ \ss'' ts' -> o {coCreate = concat ss'' ++ concat ts'}
-- NOTE keep statement and transfer readers separate because the former needs
-- the IO monad, and thus will throw IO errors rather than using the ExceptT
@ -41,8 +55,8 @@ readHistTransfer
=> PairedTransfer
-> m [Tx CommitR]
readHistTransfer ht = do
bounds <- asks (unHSpan . csHistoryScope)
expandTransfer c historyName bounds ht
bounds <- asks (unHSpan . tsHistoryScope)
expandTransfer c bounds ht
where
c = CommitR (CommitHash $ hash ht) CTHistoryTransfer
@ -53,23 +67,28 @@ readHistStmt
:: (MonadUnliftIO m, MonadFinance m)
=> FilePath
-> Statement
-> m [Tx CommitR]
-> m (Either AppException [Tx CommitR])
readHistStmt root i = do
bounds <- asks (unHSpan . tsHistoryScope)
bs <- readImport root i
bounds <- asks (unHSpan . csHistoryScope)
return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
return $ filter (inDaySpan bounds . txmDate . txMeta) . fmap go <$> bs
where
c = CommitR (CommitHash $ hash i) CTHistoryStatement
go t@Tx {txMeta = m} =
t {txMeta = m {txmCommit = CommitR (CommitHash $ hash i) CTHistoryStatement}}
-- TODO this probably won't scale well (pipes?)
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
readImport
:: (MonadUnliftIO m, MonadFinance m)
=> FilePath
-> Statement
-> m (Either AppException [Tx ()])
readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
let ores = compileOptions stmtTxOpts
let cres = combineErrors $ compileMatch <$> stmtParsers
(compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
records <- L.sort . concat <$> mapErrorsIO readStmt paths
fromEither =<< runExceptT (matchRecords compiledMatches records)
runExceptT (matchRecords compiledMatches records)
where
paths = (root </>) <$> stmtPaths
@ -93,39 +112,93 @@ readImport_ n delim tns p = do
-- TODO handle this better, this maybe thing is a hack to skip lines with
-- blank dates but will likely want to make this more flexible
parseTxRecord :: FilePath -> TxOptsRe -> NamedRecord -> Parser (Maybe TxRecord)
parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFmt} r = do
d <- r .: T.encodeUtf8 toDate
if d == ""
then return Nothing
else do
a <- parseDecimal toAmountFmt =<< r .: T.encodeUtf8 toAmount
e <- r .: T.encodeUtf8 toDesc
os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther
d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
return $ Just $ TxRecord d' a e os p
parseTxRecord
p
TxOpts
{ toDate
, toDesc
, toAmount
, toOther
, toDateFmt
, toSkipBlankDate
, toSkipBlankAmount
, toSkipBlankDescription
, toSkipBlankOther
, toSkipMissingFields
}
r =
do
-- TODO this is confusing as hell
--
-- try and parse all fields; if a parse fails, either trip an error
-- or return a Nothing if we want to deliberately skip missing fields
d <- getField toDate
e <- getField toDesc
os <-
fmap M.fromList . sequence
<$> mapM (\n -> fmap (n,) <$> getField n) toOther
(af, ax) <- case toAmount of
-- the amount column is extra confusing because it can either be one
-- or two columns, so keep track of this with a maybe
AmountSingle TxAmount1 {a1Column, a1Fmt} -> do
f <- getField a1Column
return (a1Fmt, Right <$> f)
AmountDual TxAmount2 {a2Positive, a2Negative, a2Fmt} -> do
f1 <- getField a2Positive
f2 <- getField a2Negative
return $ (a2Fmt,) $ case (f1, f2) of
(Just a, Just b) -> Just $ Left (a, b)
_ -> Nothing
case (d, e, os, ax) of
-- If all lookups were successful, check that none of the fields are
-- blank, and if they are return nothing to skip this line
(Just d', Just e', Just os', Just ax') ->
if (toSkipBlankDate && d' == "")
|| (toSkipBlankDescription && e' == "")
|| (toSkipBlankAmount && (ax' == Right "" || ax' == Left ("", "")))
|| elem "" (mapMaybe (`M.lookup` os') toSkipBlankOther)
then return Nothing
else -- if we are skipping nothing, proceed to parse the date and amount
-- columns
do
a <- case ax' of
Right a -> parseDecimal True af a
Left ("", a) -> ((-1) *) <$> parseDecimal False af a
Left (a, _) -> parseDecimal False af a
d'' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d'
return $ Just $ TxRecord d'' a e' os' p
-- if no lookups succeeded, return nothing to skip this line. Note that
-- a parse fail will trigger a failure error further up, so that case
-- is already dealt with implicitly
_ -> return Nothing
where
getField :: FromField a => T.Text -> Parser (Maybe a)
getField f = case runParser $ r .: T.encodeUtf8 f of
Left err -> if toSkipMissingFields then return Nothing else fail err
Right x -> return $ Just x
matchRecords :: MonadFinance m => [MatchRe] -> [TxRecord] -> AppExceptT m [Tx ()]
matchRecords :: MonadFinance m => [StatementParserRe] -> [TxRecord] -> AppExceptT m [Tx ()]
matchRecords ms rs = do
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
case (matched, unmatched, notfound) of
(ms_, [], []) -> return ms_
(_, us, ns) -> throwError $ AppException [StatementError us ns]
matchPriorities :: [MatchRe] -> [MatchGroup]
matchPriorities :: [StatementParserRe] -> [MatchGroup]
matchPriorities =
fmap matchToGroup
. L.groupBy (\a b -> spPriority a == spPriority b)
. L.sortOn (Down . spPriority)
matchToGroup :: [MatchRe] -> MatchGroup
matchToGroup :: [StatementParserRe] -> MatchGroup
matchToGroup ms =
uncurry MatchGroup $
first (L.sortOn spDate) $
L.partition (isJust . spDate) ms
data MatchGroup = MatchGroup
{ mgDate :: ![MatchRe]
, mgNoDate :: ![MatchRe]
{ mgDate :: ![StatementParserRe]
, mgNoDate :: ![StatementParserRe]
}
deriving (Show)
@ -164,9 +237,9 @@ zipperSlice f x = go
zipperMatch
:: MonadFinance m
=> Unzipped MatchRe
=> Unzipped StatementParserRe
-> TxRecord
-> AppExceptT m (Zipped MatchRe, MatchRes (Tx ()))
-> AppExceptT m (Zipped StatementParserRe, MatchRes (Tx ()))
zipperMatch (Unzipped bs cs as) x = go [] cs
where
go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
@ -181,9 +254,9 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
zipperMatch'
:: MonadFinance m
=> Zipped MatchRe
=> Zipped StatementParserRe
-> TxRecord
-> AppExceptT m (Zipped MatchRe, MatchRes (Tx ()))
-> AppExceptT m (Zipped StatementParserRe, MatchRes (Tx ()))
zipperMatch' z x = go z
where
go (Zipped bs (a : as)) = do
@ -194,7 +267,7 @@ zipperMatch' z x = go z
return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
go z' = return (z', MatchFail)
matchDec :: MatchRe -> Maybe MatchRe
matchDec :: StatementParserRe -> Maybe StatementParserRe
matchDec m = case spTimes m of
Just 1 -> Nothing
Just n -> Just $ m {spTimes = Just $ n - 1}
@ -204,7 +277,7 @@ matchAll
:: MonadFinance m
=> [MatchGroup]
-> [TxRecord]
-> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
-> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
matchAll = go ([], [])
where
go (matched, unused) gs rs = case (gs, rs) of
@ -218,7 +291,7 @@ matchGroup
:: MonadFinance m
=> MatchGroup
-> [TxRecord]
-> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
-> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
(md, rest, ud) <- matchDates ds rs
(mn, unmatched, un) <- matchNonDates ns rest
@ -226,9 +299,9 @@ matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
matchDates
:: MonadFinance m
=> [MatchRe]
=> [StatementParserRe]
-> [TxRecord]
-> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
-> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
matchDates ms = go ([], [], initZipper ms)
where
go (matched, unmatched, z) [] =
@ -251,9 +324,9 @@ matchDates ms = go ([], [], initZipper ms)
matchNonDates
:: MonadFinance m
=> [MatchRe]
=> [StatementParserRe]
-> [TxRecord]
-> AppExceptT m ([Tx ()], [TxRecord], [MatchRe])
-> AppExceptT m ([Tx ()], [TxRecord], [StatementParserRe])
matchNonDates ms = go ([], [], initZipper ms)
where
go (matched, unmatched, z) [] =
@ -270,7 +343,11 @@ matchNonDates ms = go ([], [], initZipper ms)
MatchFail -> (matched, r : unmatched)
in go (m, u, resetZipper z') rs
matches :: MonadFinance m => MatchRe -> TxRecord -> AppExceptT m (MatchRes (Tx ()))
matches
:: MonadFinance m
=> StatementParserRe
-> TxRecord
-> AppExceptT m (MatchRes (Tx ()))
matches
StatementParser {spTx, spOther, spVal, spDate, spDesc, spPriority}
r@TxRecord {trDate, trAmount, trDesc, trOther} = do
@ -300,9 +377,7 @@ toTx
r@TxRecord {trAmount, trDate, trDesc} = do
combineError curRes subRes $ \(cur, f, t) ss ->
Tx
{ txDate = trDate
, txDescr = trDesc
, txCommit = ()
{ txMeta = TxMeta trDate priority trDesc ()
, txPrimary =
Left $
EntrySet
@ -312,12 +387,10 @@ toTx
, esTo = t
}
, txOther = Left <$> ss
, txBudget = historyName
, txPriority = priority
}
where
curRes = do
m <- asks csCurrencyMap
m <- asks tsCurrencyMap
cur <- liftInner $ resolveCurrency m r tgCurrency
let prec = cpPrec cur
let fromRes = liftInner $ resolveHalfEntry resolveFromValue prec r () tgFrom
@ -331,7 +404,7 @@ resolveSubGetter
-> TxSubGetter
-> AppExceptT m SecondayEntrySet
resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
m <- asks csCurrencyMap
m <- asks tsCurrencyMap
cur <- liftInner $ resolveCurrency m r tsgCurrency
let prec = cpPrec cur
let toRes = resolveHalfEntry resolveToValue prec r () tsgTo
@ -449,11 +522,17 @@ readRational s = case T.split (== '.') s of
err = throwError $ AppException [ConversionError s False]
compileOptions :: TxOpts T.Text -> AppExcept TxOptsRe
compileOptions o@TxOpts {toAmountFmt = pat} = do
re <- compileRegex True pat
return $ o {toAmountFmt = re}
compileOptions = mapM (compileRegex True)
compileMatch :: StatementParser T.Text -> AppExcept MatchRe
-- compileOptions o@TxOpts {toAmount = pat} = case pat of
-- AmountSingle (TxAmount1 {a1Fmt}) -> do
-- re <- compileRegex True a1Fmt
-- return $ o {toAmountFmt = re}
-- AmountDual (TxAmount2 {a2Fmt}) -> do
-- re <- compileRegex True a2Fmt
-- return $ o {toAmountFmt = re}
compileMatch :: StatementParser T.Text -> AppExcept StatementParserRe
compileMatch m@StatementParser {spDesc, spOther} = do
combineError dres ores $ \d os -> m {spDesc = d, spOther = os}
where
@ -461,42 +540,15 @@ compileMatch m@StatementParser {spDesc, spOther} = do
dres = mapM go spDesc
ores = combineErrors $ fmap (mapM go) spOther
compileRegex :: Bool -> T.Text -> AppExcept (Text, Regex)
compileRegex groups pat = case res of
Right re -> return (pat, re)
Left _ -> throwError $ AppException [RegexError pat]
where
res =
compile
(blankCompOpt {newSyntax = True})
(blankExecOpt {captureGroups = groups})
pat
matchMaybe :: T.Text -> Regex -> AppExcept Bool
matchMaybe q re = case execute re q of
Right res -> return $ isJust res
Left _ -> throwError $ AppException [RegexError "this should not happen"]
matchGroupsMaybe :: T.Text -> Regex -> [T.Text]
matchGroupsMaybe q re = case regexec re q of
Right Nothing -> []
Right (Just (_, _, _, xs)) -> xs
-- this should never fail as regexec always returns Right
Left _ -> []
parseDecimal :: MonadFail m => (T.Text, Regex) -> T.Text -> m Decimal
parseDecimal (pat, re) s = case matchGroupsMaybe s re of
[sign, x, ""] -> Decimal 0 . uncurry (*) <$> readWhole sign x
[sign, x, y] -> do
d <- readT "decimal" y
let p = T.length y
(k, w) <- readWhole sign x
return $ Decimal (fromIntegral p) (k * (w * (10 ^ p) + d))
parseDecimal :: MonadFail m => Bool -> (T.Text, Regex) -> T.Text -> m Decimal
parseDecimal wantSign (pat, re) s = case (wantSign, matchGroupsMaybe s re) of
(True, [sign, num]) -> do
k <- readSign sign
x <- readNum num
return $ k * x
(False, [num]) -> readNum num
_ -> msg "malformed decimal"
where
readT what t = case readMaybe $ T.unpack t of
Just d -> return $ fromInteger d
_ -> msg $ T.unwords ["could not parse", what, singleQuote t]
msg :: MonadFail m => T.Text -> m a
msg m =
fail $
@ -506,10 +558,10 @@ parseDecimal (pat, re) s = case matchGroupsMaybe s re of
| x == "-" = return (-1)
| x == "+" || x == "" = return 1
| otherwise = msg $ T.append "invalid sign: " x
readWhole sign x = do
w <- readT "whole number" x
k <- readSign sign
return (k, w)
historyName :: BudgetName
historyName = BudgetName "history"
readNum x =
maybe
(msg $ T.unwords ["could not parse", singleQuote x])
return
$ readMaybe
$ T.unpack
$ T.filter (/= ',') x

View File

@ -24,10 +24,12 @@ CommitR sql=commits
type ConfigType
UniqueCommitHash hash
deriving Show Eq Ord
ConfigStateR sql=config_state
historySpan HistorySpan
budgetSpan BudgetSpan
deriving Show
CurrencyR sql=currencies
symbol CurID
fullname T.Text
@ -35,12 +37,14 @@ CurrencyR sql=currencies
UniqueCurrencySymbol symbol
UniqueCurrencyFullname fullname
deriving Show Eq Ord
TagR sql=tags
symbol TagID
fullname T.Text
UniqueTagSymbol symbol
UniqueTagFullname fullname
deriving Show Eq Ord
AccountR sql=accounts
name T.Text
fullpath AcntPath
@ -49,24 +53,28 @@ AccountR sql=accounts
leaf Bool
UniqueAccountFullpath fullpath
deriving Show Eq Ord
AccountPathR sql=account_paths
parent AccountRId
child AccountRId
depth Int
deriving Show Eq Ord
TransactionR sql=transactions
commit CommitRId
date Day
description TxDesc
budgetName BudgetName
description TxDesc
priority Int
deriving Show Eq
EntrySetR sql=entry_sets
transaction TransactionRId
currency CurrencyRId
index EntrySetIndex
rebalance Bool
deriving Show Eq
EntryR sql=entries
entryset EntrySetRId
account AccountRId
@ -77,12 +85,16 @@ EntryR sql=entries
cachedType (Maybe TransferType)
cachedLink (Maybe EntryIndex)
deriving Show Eq
TagRelationR sql=tag_relations
entry EntryRId
tag TagRId
deriving Show Eq
|]
newtype TxIndex = TxIndex {unTxIndex :: Int}
deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
newtype EntrySetIndex = EntrySetIndex {unEntrySetIndex :: Int}
deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
@ -90,7 +102,7 @@ newtype EntryIndex = EntryIndex {unEntryIndex :: Int}
deriving newtype (Show, Eq, Ord, Num, Real, Enum, Integral, PersistField, PersistFieldSql)
newtype TxDesc = TxDesc {unTxDesc :: T.Text}
deriving newtype (Show, Eq, Ord, PersistField, PersistFieldSql, FromField)
deriving newtype (Show, Eq, Ord, PersistField, PersistFieldSql, FromField, IsString)
newtype Precision = Precision {unPrecision :: Word8}
deriving newtype (Eq, Ord, Num, Show, Real, Enum, Integral, PersistField, PersistFieldSql)

View File

@ -49,17 +49,16 @@ makeHaskellTypesWith
, SingleConstructor "ModPat" "ModPat" "(./dhall/Types.dhall).ModPat.Type"
, SingleConstructor "CronPat" "CronPat" "(./dhall/Types.dhall).CronPat.Type"
, SingleConstructor "ValMatcher" "ValMatcher" "(./dhall/Types.dhall).ValMatcher.Type"
, SingleConstructor "TxAmount1" "TxAmount1" "(./dhall/Types.dhall).TxAmount1_"
, SingleConstructor "TxAmount2" "TxAmount2" "(./dhall/Types.dhall).TxAmount2_"
, SingleConstructor
"Amount"
"Amount"
"\\(w : Type) -> \\(v : Type) -> ((./dhall/Types.dhall).Amount w v).Type"
, SingleConstructor
"TxOpts"
"TxOpts"
"\\(re : Type) -> ((./dhall/Types.dhall).TxOpts_ re).Type"
, SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
, SingleConstructor "TransferMatcher" "TransferMatcher" "(./dhall/Types.dhall).TransferMatcher.Type"
, SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
"AcntMatcher_"
"AcntMatcher_"
"\\(re : Type) -> ((./dhall/Types.dhall).AcntMatcher_ re).Type"
, SingleConstructor "Field" "Field" "(./dhall/Types.dhall).Field"
, SingleConstructor "Entry" "Entry" "(./dhall/Types.dhall).Entry"
, SingleConstructor "PretaxValue" "PretaxValue" "(./dhall/Types.dhall).PretaxValue"
@ -88,11 +87,7 @@ deriveProduct
, "CronPat"
, "DatePat"
, "TaggedAcnt"
, "Budget"
, "Income"
, "ShadowTransfer"
, "TransferMatcher"
, "AcntSet"
, "DateMatcher"
, "ValMatcher"
, "YMDMatcher"
@ -191,15 +186,33 @@ newtype BudgetName = BudgetName {unBudgetName :: T.Text}
deriving newtype (Show, Eq, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
data Budget = Budget
{ bgtLabel :: BudgetName
, bgtIncomes :: [Income]
, bgtPretax :: [MultiAllocation PretaxValue]
, bgtTax :: [MultiAllocation TaxValue]
, bgtPosttax :: [MultiAllocation PosttaxValue]
, bgtTransfers :: [PairedTransfer]
, bgtShadowTransfers :: [ShadowTransfer]
{ bgtLabel :: !BudgetName
, bgtIncomes :: ![Income]
, bgtPretax :: ![MultiAllocation PretaxValue]
, bgtTax :: ![MultiAllocation TaxValue]
, bgtPosttax :: ![MultiAllocation PosttaxValue]
, bgtTransfers :: ![PairedTransfer]
, bgtShadowTransfers :: ![ShadowTransfer]
, bgtInterval :: !(Maybe Interval)
}
deriving (Generic, Hashable, FromDhall)
data ShadowTransfer = ShadowTransfer
{ stFrom :: !TaggedAcnt
, stTo :: !TaggedAcnt
, stCurrency :: !CurID
, stDesc :: !Text
, stMatch :: !(TransferMatcher_ Text)
, stRatio :: !Double
}
deriving (Generic, Hashable, FromDhall)
data TransferMatcher_ re = TransferMatcher_
{ tmFrom :: !(Maybe (AcntMatcher_ re))
, tmTo :: !(Maybe (AcntMatcher_ re))
, tmDate :: !(Maybe DateMatcher)
, tmVal :: !ValMatcher
}
deriving instance Hashable PretaxValue
@ -213,8 +226,6 @@ deriving instance Hashable TaxValue
deriving instance Hashable PosttaxValue
deriving instance Hashable Budget
deriving instance Hashable TransferValue
deriving instance Hashable TransferType
@ -314,11 +325,17 @@ data Transfer a c w v = Transfer
}
deriving (Eq, Show)
deriving instance Hashable ShadowTransfer
deriving instance Generic (TransferMatcher_ Text)
deriving instance Hashable AcntSet
deriving instance Hashable (TransferMatcher_ Text)
deriving instance Hashable TransferMatcher
deriving instance FromDhall (TransferMatcher_ Text)
deriving instance Generic (AcntMatcher_ Text)
deriving instance Hashable (AcntMatcher_ Text)
deriving instance FromDhall (AcntMatcher_ Text)
deriving instance Hashable ValMatcher
@ -449,12 +466,44 @@ deriving instance Eq a => Eq (TxOpts a)
deriving instance Generic (TxOpts a)
deriving instance Hashable a => Hashable (TxOpts a)
deriving instance Hashable (TxOpts T.Text)
deriving instance FromDhall a => FromDhall (TxOpts a)
deriving instance FromDhall (TxOpts T.Text)
deriving instance Show a => Show (TxOpts a)
deriving instance Eq re => Eq (TxAmount1 re)
deriving instance Eq re => Eq (TxAmount2 re)
deriving instance Show re => Show (TxAmount1 re)
deriving instance Show re => Show (TxAmount2 re)
deriving instance Generic (TxAmount1 T.Text)
deriving instance Generic (TxAmount2 T.Text)
deriving instance Hashable (TxAmount1 T.Text)
deriving instance Hashable (TxAmount2 T.Text)
deriving instance FromDhall (TxAmount1 T.Text)
deriving instance FromDhall (TxAmount2 T.Text)
deriving instance Functor TxAmount1
deriving instance Functor TxAmount2
deriving instance Foldable TxAmount1
deriving instance Foldable TxAmount2
deriving instance Traversable TxAmount1
deriving instance Traversable TxAmount2
data Statement = Statement
{ stmtPaths :: ![FilePath]
, stmtParsers :: ![StatementParser T.Text]
@ -464,6 +513,29 @@ data Statement = Statement
}
deriving (Eq, Hashable, Generic, FromDhall, Show)
data TxAmountSpec re = AmountSingle (TxAmount1 re) | AmountDual (TxAmount2 re)
deriving (Eq, Show, Functor, Foldable, Traversable)
deriving instance Generic (TxAmountSpec T.Text)
deriving instance FromDhall (TxAmountSpec T.Text)
deriving instance Hashable (TxAmountSpec T.Text)
data TxOpts re = TxOpts
{ toDate :: !T.Text
, toAmount :: !(TxAmountSpec re)
, toDesc :: !T.Text
, toOther :: ![T.Text]
, toDateFmt :: !T.Text
, toSkipBlankDate :: !Bool
, toSkipBlankAmount :: !Bool
, toSkipBlankDescription :: !Bool
, toSkipBlankOther :: ![Text]
, toSkipMissingFields :: !Bool
}
deriving (Functor, Foldable, Traversable)
-- | the value of a field in entry (text version)
-- can either be a raw (constant) value, a lookup from the record, or a map
-- between the lookup and some other value

View File

@ -26,32 +26,51 @@ import Text.Regex.TDFA
--------------------------------------------------------------------------------
-- database cache types
type MonadFinance = MonadReader ConfigState
type MonadFinance = MonadReader TxState
data DeleteTxs = DeleteTxs
{ dtTxs :: ![TransactionRId]
{ dtCommits :: ![CommitRId]
, dtTxs :: ![TransactionRId]
, dtEntrySets :: ![EntrySetRId]
, dtEntries :: ![EntryRId]
, dtTagRelations :: ![TagRelationRId]
}
deriving (Show)
type CDOps c d = CRUDOps [c] () () [d]
type EntityCRUDOps r = CRUDOps [Entity r] () () [Key r]
-- TODO split the entry stuff from the account metadata stuff
data ConfigState = ConfigState
{ csCurrencies :: !(CDOps (Entity CurrencyR) CurrencyRId)
, csAccounts :: !(CDOps (Entity AccountR) AccountRId)
, csPaths :: !(CDOps (Entity AccountPathR) AccountPathRId)
, csTags :: !(CDOps (Entity TagR) TagRId)
, csBudgets :: !(CRUDOps [Budget] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
, csHistTrans :: !(CRUDOps [PairedTransfer] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
, csHistStmts :: !(CRUDOps [Statement] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
, csAccountMap :: !AccountMap
, csCurrencyMap :: !CurrencyMap
, csTagMap :: !TagMap
, csBudgetScope :: !BudgetSpan
, csHistoryScope :: !HistorySpan
data MetaCRUD = MetaCRUD
{ mcCurrencies :: !(EntityCRUDOps CurrencyR)
, mcAccounts :: !(EntityCRUDOps AccountR)
, mcPaths :: !(EntityCRUDOps AccountPathR)
, mcTags :: !(EntityCRUDOps TagR)
, mcBudgetScope :: !BudgetSpan
, mcHistoryScope :: !HistorySpan
}
type BudgetCRUDOps b = CRUDOps [b] () () DeleteTxs
type PreBudgetCRUD = BudgetCRUDOps Budget
type FinalBudgetCRUD = BudgetCRUDOps (BudgetName, [Tx CommitR])
type HistoryCRUDOps h =
CRUDOps
h
[ReadEntry]
[Either TotalUpdateEntrySet FullUpdateEntrySet]
DeleteTxs
type PreHistoryCRUD = HistoryCRUDOps ([PairedTransfer], [Statement])
type FinalHistoryCRUD = HistoryCRUDOps [Tx CommitR]
data TxState = TxState
{ tsAccountMap :: !AccountMap
, tsCurrencyMap :: !CurrencyMap
, tsTagMap :: !TagMap
, tsBudgetScope :: !BudgetSpan
, tsHistoryScope :: !HistorySpan
}
deriving (Show)
@ -83,13 +102,22 @@ data CachedEntry
| CachedBalance Decimal
| CachedPercent Double
data TxSortKey = TxSortKey
{ tskDate :: !Day
, tskPriority :: !Int
, tskDesc :: !TxDesc
}
deriving (Show, Eq, Ord)
-- TODO this should actually be a ReadTx since it will be compared with other
-- Tx's to get the insert/update order correct
data ReadEntry = ReadEntry
{ reCurrency :: !CurrencyRId
, reAcnt :: !AccountRId
, reValue :: !Decimal
, reDate :: !Day
, rePriority :: !Int
, reBudget :: !BudgetName
, reIndex :: !EntryIndex
, reESIndex :: !EntrySetIndex
, reSortKey :: !TxSortKey
}
deriving (Show)
@ -129,10 +157,9 @@ data UpdateEntrySet f t = UpdateEntrySet
, utFromRO :: ![UE_RO]
, utToRO :: ![UE_RO]
, utCurrency :: !CurrencyRId
, utDate :: !Day
, utTotalValue :: !t
, utBudget :: !BudgetName
, utPriority :: !Int
, utIndex :: !EntrySetIndex
, utSortKey :: !TxSortKey
}
deriving (Show)
@ -195,14 +222,18 @@ type ShadowEntrySet = TotalEntrySet Double EntryValue EntryLink
data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text
deriving (Eq, Ord, Show)
data TxMeta k = TxMeta
{ txmDate :: !Day
, txmPriority :: !Int
, txmDesc :: !TxDesc
, txmCommit :: !k
}
deriving (Show, Eq, Ord)
data Tx k = Tx
{ txDescr :: !TxDesc
, txDate :: !Day
, txPriority :: !Int
{ txMeta :: !(TxMeta k)
, txPrimary :: !(Either PrimaryEntrySet TransferEntrySet)
, txOther :: ![Either SecondayEntrySet ShadowEntrySet]
, txCommit :: !k
, txBudget :: !BudgetName
}
deriving (Generic, Show)
@ -218,12 +249,8 @@ data InsertEntrySet = InsertEntrySet
}
data InsertTx = InsertTx
{ itxDescr :: !TxDesc
, itxDate :: !Day
, itxPriority :: !Int
{ itxMeta :: !(TxMeta CommitR)
, itxEntrySets :: !(NonEmpty InsertEntrySet)
, itxCommit :: !CommitR
, itxBudget :: !BudgetName
}
deriving (Generic)
@ -279,7 +306,7 @@ data AppError
| LookupError !LookupSuberr !T.Text
| DatePatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
| DaySpanError !Gregorian !(Maybe Gregorian)
| StatementError ![TxRecord] ![MatchRe]
| StatementError ![TxRecord] ![StatementParserRe]
| PeriodError !Day !Day
| LinkError !EntryIndex !EntryIndex
| DBError !DBSubError
@ -296,7 +323,9 @@ type AppExceptT = ExceptT AppException
type AppExcept = AppExceptT Identity
type MatchRe = StatementParser (T.Text, Regex)
type StatementParserRe = StatementParser (T.Text, Regex)
type TransferMatcherRe = TransferMatcher_ Regex
type TxOptsRe = TxOpts (T.Text, Regex)

View File

@ -51,6 +51,9 @@ module Internal.Utils
, keyVals
, realFracToDecimalP
, roundToP
, compileRegex
, matchMaybe
, matchGroupsMaybe
)
where
@ -69,6 +72,8 @@ import RIO.State
import qualified RIO.Text as T
import RIO.Time
import qualified RIO.Vector as V
import Text.Regex.TDFA hiding (matchAll)
import Text.Regex.TDFA.Text
--------------------------------------------------------------------------------
-- intervals
@ -125,7 +130,7 @@ expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
expandMDYPat :: Natural -> Natural -> MDYPat -> AppExcept [Natural]
expandMDYPat lower upper (Single x) = return [x | lower <= x && x <= upper]
expandMDYPat lower upper (Multi xs) = return $ dropWhile (<= lower) $ takeWhile (<= upper) xs
expandMDYPat lower upper (Multi xs) = return $ dropWhile (< lower) $ takeWhile (<= upper) xs
expandMDYPat lower upper (After x) = return [max lower x .. upper]
expandMDYPat lower upper (Before x) = return [lower .. min upper x]
expandMDYPat lower upper (Between x y) = return [max lower x .. min upper y]
@ -151,7 +156,7 @@ askDays
-> Maybe Interval
-> m [Day]
askDays dp i = do
globalSpan <- asks (unBSpan . csBudgetScope)
globalSpan <- asks (unBSpan . tsBudgetScope)
case i of
Just i' -> do
localSpan <- liftExcept $ resolveDaySpan i'
@ -494,7 +499,7 @@ showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
, ("description", doubleQuote $ unTxDesc e)
]
showMatch :: MatchRe -> T.Text
showMatch :: StatementParserRe -> T.Text
showMatch StatementParser {spDate, spVal, spDesc, spOther, spTimes, spPriority} =
T.append "Unused match: " $ keyVals [(x, y) | (x, Just y) <- kvs]
where
@ -599,7 +604,7 @@ uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 f (a, b, c) = f a b c
lookupAccount :: (MonadAppError m, MonadFinance m) => AcntID -> m (AccountRId, AcntType)
lookupAccount = lookupFinance AcntField csAccountMap
lookupAccount = lookupFinance AcntField tsAccountMap
lookupAccountKey :: (MonadAppError m, MonadFinance m) => AcntID -> m AccountRId
lookupAccountKey = fmap fst . lookupAccount
@ -608,7 +613,7 @@ lookupAccountType :: (MonadAppError m, MonadFinance m) => AcntID -> m AcntType
lookupAccountType = fmap snd . lookupAccount
lookupCurrency :: (MonadAppError m, MonadFinance m) => CurID -> m CurrencyPrec
lookupCurrency = lookupFinance CurField csCurrencyMap
lookupCurrency = lookupFinance CurField tsCurrencyMap
lookupCurrencyKey :: (MonadAppError m, MonadFinance m) => CurID -> m CurrencyRId
lookupCurrencyKey = fmap cpID . lookupCurrency
@ -617,12 +622,12 @@ lookupCurrencyPrec :: (MonadAppError m, MonadFinance m) => CurID -> m Precision
lookupCurrencyPrec = fmap cpPrec . lookupCurrency
lookupTag :: (MonadAppError m, MonadFinance m) => TagID -> m TagRId
lookupTag = lookupFinance TagField csTagMap
lookupTag = lookupFinance TagField tsTagMap
lookupFinance
:: (MonadAppError m, MonadFinance m, Ord k, Show k)
=> EntryIDType
-> (ConfigState -> M.Map k a)
-> (TxState -> M.Map k a)
-> k
-> m a
lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< asks f
@ -639,39 +644,38 @@ balanceTxs ebs =
fmap (Just . Left) $
liftInnerS $
either rebalanceTotalEntrySet rebalanceFullEntrySet utx
go (ToRead ReadEntry {reCurrency, reAcnt, reValue, reBudget}) = do
modify $ mapAdd_ (reAcnt, (reCurrency, reBudget)) reValue
go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
modify $ mapAdd_ (reAcnt, reCurrency) reValue
return Nothing
go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate, txBudget, txPriority}) = do
e <- either (balancePrimaryEntrySet txBudget) (balanceSecondaryEntrySet txBudget) txPrimary
go (ToInsert Tx {txPrimary, txOther, txMeta}) = do
e <- either balancePrimaryEntrySet balanceSecondaryEntrySet txPrimary
let tot = sum $ fmap (eValue . ieEntry) $ NE.toList $ iesFromEntries e
es <- mapErrors (goOther tot) txOther
let tx =
-- TODO this is lame
InsertTx
{ itxDescr = txDescr
, itxDate = txDate
, itxEntrySets = e :| es
, itxCommit = txCommit
, itxBudget = txBudget
, itxPriority = txPriority
}
let tx = InsertTx {itxMeta = txMeta, itxEntrySets = e :| es}
return $ Just $ Right tx
where
goOther tot =
either
(balanceSecondaryEntrySet txBudget)
(balancePrimaryEntrySet txBudget . fromShadow tot)
balanceSecondaryEntrySet
(balancePrimaryEntrySet . fromShadow tot)
fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot *. esTotalValue}
binDate :: EntryCRU -> (Day, Int)
binDate (ToRead ReadEntry {reDate, rePriority}) = (reDate, rePriority)
binDate (ToInsert Tx {txDate, txPriority}) = (txDate, txPriority)
-- NOTE this sorting thing is super wonky; I'm basically sorting three different
-- levels of the hierarchy directory and assuming there will be no overlaps.
-- First, sort at the transaction level by day, priority, and description as
-- tiebreaker. Anything that shares those three keys will have an unstable sort
-- order. Within the entrysets, use the index as it appears in the
-- configuration, and same with the entries. Since we assume no overlap, nothing
-- "bad" should happen if the levels above entries/entrysets sort on 'Nothing'
-- for the indices they don't have at their level.
binDate :: EntryCRU -> (TxSortKey, Maybe EntrySetIndex, Maybe EntryIndex)
binDate (ToRead ReadEntry {reSortKey, reESIndex, reIndex}) = (reSortKey, Just reESIndex, Just reIndex)
binDate (ToInsert Tx {txMeta = (TxMeta t p d _)}) = (TxSortKey t p d, Nothing, Nothing)
binDate (ToUpdate u) = either go go u
where
go UpdateEntrySet {utDate, utPriority} = (utDate, utPriority)
go UpdateEntrySet {utSortKey, utIndex} = (utSortKey, Just utIndex, Nothing)
type BCKey = (CurrencyRId, BudgetName)
type BCKey = CurrencyRId
type ABCKey = (AccountRId, BCKey)
@ -692,17 +696,14 @@ rebalanceTotalEntrySet
, utToRO
, utCurrency
, utTotalValue
, utBudget
} =
do
(fval, fs, tpairs) <- rebalanceDebit bc utFromRO utFromUnk
(fval, fs, tpairs) <- rebalanceDebit utCurrency utFromRO utFromUnk
let f0val = utTotalValue - fval
modify $ mapAdd_ (f0Acnt, bc) f0val
modify $ mapAdd_ (f0Acnt, utCurrency) f0val
let tsLinked = tpairs ++ (unlink f0val <$> f0links)
ts <- rebalanceCredit bc utTotalValue utTo0 utToUnk utToRO tsLinked
ts <- rebalanceCredit utCurrency utTotalValue utTo0 utToUnk utToRO tsLinked
return (f0 {ueValue = StaticValue f0val} : fs ++ ts)
where
bc = (utCurrency, utBudget)
rebalanceFullEntrySet :: FullUpdateEntrySet -> State EntryBals [UEBalanced]
rebalanceFullEntrySet
@ -714,17 +715,15 @@ rebalanceFullEntrySet
, utFromRO
, utToRO
, utCurrency
, utBudget
} =
do
(ftot, fs, tpairs) <- rebalanceDebit bc rs ls
ts <- rebalanceCredit bc ftot utTo0 utToUnk utToRO tpairs
(ftot, fs, tpairs) <- rebalanceDebit utCurrency rs ls
ts <- rebalanceCredit utCurrency ftot utTo0 utToUnk utToRO tpairs
return (fs ++ ts)
where
(rs, ls) = case utFrom0 of
Left x -> (x : utFromRO, utFromUnk)
Right x -> (utFromRO, x : utFromUnk)
bc = (utCurrency, utBudget)
rebalanceDebit
:: BCKey
@ -758,7 +757,7 @@ rebalanceCredit
-> [UE_RO]
-> [UEBalanced]
-> State EntryBals [UEBalanced]
rebalanceCredit k tot t0 us rs bs = do
rebalanceCredit k tot t0@UpdateEntry {ueAcnt = t0Acnt} us rs bs = do
(tval, ts) <-
fmap (second catMaybes) $
sumM goTo $
@ -766,7 +765,9 @@ rebalanceCredit k tot t0 us rs bs = do
(UETLinked <$> bs)
++ (UETUnk <$> us)
++ (UETReadOnly <$> rs)
return (t0 {ueValue = StaticValue (-(tot + tval))} : ts)
let t0val = -(tot + tval)
modify $ mapAdd_ (t0Acnt, k) t0val
return (t0 {ueValue = StaticValue t0val} : ts)
where
idx = projectUET ueIndex ueIndex ueIndex
goTo (UETReadOnly e) = (,Nothing) <$> updateFixed k e
@ -806,11 +807,9 @@ updateUnknown k e = do
balancePrimaryEntrySet
:: (MonadAppError m, MonadFinance m)
=> BudgetName
-> PrimaryEntrySet
=> PrimaryEntrySet
-> StateT EntryBals m InsertEntrySet
balancePrimaryEntrySet
budgetName
EntrySet
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
@ -822,7 +821,7 @@ balancePrimaryEntrySet
let t0res = resolveAcntAndTags t0
let fsres = mapErrors resolveAcntAndTags fs
let tsres = mapErrors resolveAcntAndTags ts
let bc = (esCurrency, budgetName)
let bc = esCurrency
combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $
\(f0', fs') (t0', ts') -> do
let balFrom = fmap liftInnerS . balanceDeferred
@ -831,11 +830,9 @@ balancePrimaryEntrySet
balanceSecondaryEntrySet
:: (MonadAppError m, MonadFinance m)
=> BudgetName
-> SecondayEntrySet
=> SecondayEntrySet
-> StateT EntryBals m InsertEntrySet
balanceSecondaryEntrySet
budgetName
EntrySet
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
@ -852,7 +849,7 @@ balanceSecondaryEntrySet
where
entrySum = sum . fmap (eValue . ieEntry)
balFrom = balanceEntry (fmap liftInnerS . balanceDeferred) bc
bc = (esCurrency, budgetName)
bc = esCurrency
balanceFinal
:: (MonadAppError m)
@ -862,10 +859,10 @@ balanceFinal
-> Entry AccountRId () TagRId
-> [Entry AccountRId EntryLink TagRId]
-> StateT EntryBals m InsertEntrySet
balanceFinal k@(curID, _) tot fs t0 ts = do
balanceFinal curID tot fs t0 ts = do
let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs
let balTo = balanceLinked fv
ts' <- balanceTotalEntrySet balTo k tot t0 ts
ts' <- balanceTotalEntrySet balTo curID tot t0 ts
return $
InsertEntrySet
{ iesCurrency = curID
@ -963,20 +960,18 @@ findBalance k e = do
expandTransfers
:: (MonadAppError m, MonadFinance m)
=> CommitR
-> BudgetName
-> DaySpan
-> [PairedTransfer]
-> m [Tx CommitR]
expandTransfers tc name bounds = fmap concat . mapErrors (expandTransfer tc name bounds)
expandTransfers tc bounds = fmap concat . mapErrors (expandTransfer tc bounds)
expandTransfer
:: (MonadAppError m, MonadFinance m)
=> CommitR
-> BudgetName
-> DaySpan
-> PairedTransfer
-> m [Tx CommitR]
expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
txs <- mapErrors go transAmounts
return $ concat txs
where
@ -997,13 +992,9 @@ expandTransfer tc name bounds Transfer {transAmounts, transTo, transCurrency, tr
withDates bounds pat $ \day ->
return
Tx
{ txCommit = tc
, txDate = day
{ txMeta = TxMeta day (fromIntegral pri) (TxDesc desc) tc
, txPrimary = Right $ entryPair transFrom transTo (cpID cp) desc () v''
, txOther = []
, txDescr = TxDesc desc
, txBudget = name
, txPriority = fromIntegral pri
}
entryPair
@ -1050,3 +1041,26 @@ realFracToDecimalP p = realFracToDecimal (unPrecision p)
roundToP :: Integral i => Precision -> DecimalRaw i -> DecimalRaw i
roundToP p = roundTo (unPrecision p)
compileRegex :: Bool -> T.Text -> AppExcept (Text, Regex)
compileRegex groups pat = case res of
Right re -> return (pat, re)
Left _ -> throwError $ AppException [RegexError pat]
where
res =
compile
(blankCompOpt {newSyntax = True})
(blankExecOpt {captureGroups = groups})
pat
matchMaybe :: T.Text -> Regex -> AppExcept Bool
matchMaybe q re = case execute re q of
Right res -> return $ isJust res
Left _ -> throwError $ AppException [RegexError "this should not happen"]
matchGroupsMaybe :: T.Text -> Regex -> [T.Text]
matchGroupsMaybe q re = case regexec re q of
Right Nothing -> []
Right (Just (_, _, _, xs)) -> xs
-- this should never fail as regexec always returns Right
Left _ -> []