pwncash/lib/Internal/Insert.hs

790 lines
26 KiB
Haskell
Raw Normal View History

2022-12-11 17:51:11 -05:00
module Internal.Insert
2023-05-13 13:53:43 -04:00
( insertBudget
, splitHistory
, insertHistTransfer
, readHistStmt
, insertHistStmt
)
where
2023-05-07 20:29:33 -04:00
import Control.Monad.Except
import Data.Hashable
2023-05-07 20:29:33 -04:00
import Database.Persist.Monad
import Internal.Statement
2023-05-07 20:29:33 -04:00
import Internal.Types
import Internal.Utils
import RIO hiding (to)
2023-02-12 16:23:32 -05:00
import qualified RIO.List as L
import qualified RIO.Map as M
2023-02-12 21:52:41 -05:00
import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T
import RIO.Time
2022-12-11 17:51:11 -05:00
--------------------------------------------------------------------------------
-- intervals
2023-05-07 20:29:33 -04:00
expandDatePat :: Bounds -> DatePat -> InsertExcept [Day]
2023-02-02 23:18:36 -05:00
expandDatePat b (Cron cp) = expandCronPat b cp
2023-05-07 20:29:33 -04:00
expandDatePat i (Mod mp) = return $ expandModPat mp i
2022-12-11 17:51:11 -05:00
2023-01-28 19:32:56 -05:00
expandModPat :: ModPat -> Bounds -> [Day]
expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs =
takeWhile (<= upper) $
(`addFun` start) . (* b')
<$> maybe id (take . fromIntegral) r [0 ..]
2023-02-02 23:18:36 -05:00
where
(lower, upper) = expandBounds bs
start = maybe lower fromGregorian' s
b' = fromIntegral b
addFun = case u of
Day -> addDays
Week -> addDays . (* 7)
Month -> addGregorianMonthsClip
Year -> addGregorianYearsClip
2023-05-07 20:29:33 -04:00
expandCronPat :: Bounds -> CronPat -> InsertExcept [Day]
2023-04-30 23:28:16 -04:00
expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
2023-05-07 20:29:33 -04:00
combineError3 yRes mRes dRes $ \ys ms ds ->
2023-02-12 16:23:32 -05:00
filter validWeekday $
mapMaybe (uncurry3 toDay) $
takeWhile (\((y, _), m, d) -> (y, m, d) <= (yb1, mb1, db1)) $
dropWhile (\((y, _), m, d) -> (y, m, d) < (yb0, mb0, db0)) $
[(y, m, d) | y <- (\y -> (y, isLeapYear y)) <$> ys, m <- ms, d <- ds]
2023-01-30 21:47:17 -05:00
where
2023-04-30 23:28:16 -04:00
yRes = case cpYear of
Nothing -> return [yb0 .. yb1]
Just pat -> do
2023-02-09 20:01:43 -05:00
ys <- expandMDYPat (fromIntegral yb0) (fromIntegral yb1) pat
return $ dropWhile (< yb0) $ fromIntegral <$> ys
2023-04-30 23:28:16 -04:00
mRes = expandMD 12 cpMonth
dRes = expandMD 31 cpDay
(s, e) = expandBounds b
(yb0, mb0, db0) = toGregorian s
(yb1, mb1, db1) = toGregorian $ addDays (-1) e
2023-02-09 20:01:43 -05:00
expandMD lim =
fmap (fromIntegral <$>)
. maybe (return [1 .. lim]) (expandMDYPat 1 lim)
expandW (OnDay x) = [fromEnum x]
expandW (OnDays xs) = fromEnum <$> xs
2023-04-30 23:28:16 -04:00
ws = maybe [] expandW cpWeekly
validWeekday = if null ws then const True else \day -> dayToWeekday day `elem` ws
toDay (y, leap) m d
| m == 2 && (not leap && d > 28 || leap && d > 29) = Nothing
| m `elem` [4, 6, 9, 11] && d > 30 = Nothing
| otherwise = Just $ fromGregorian y m d
2023-05-07 20:29:33 -04:00
expandMDYPat :: Natural -> Natural -> MDYPat -> InsertExcept [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 (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]
2023-02-09 20:01:43 -05:00
expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r})
2023-05-07 20:29:33 -04:00
| b < 1 = throwError $ InsertException [PatternError s b r ZeroLength]
| otherwise = do
k <- limit r
2023-02-09 20:01:43 -05:00
return $ dropWhile (<= lower) $ takeWhile (<= k) [s + i * b | i <- [0 ..]]
where
2023-05-07 20:29:33 -04:00
limit Nothing = return upper
limit (Just n)
-- this guard not only produces the error for the user but also protects
-- from an underflow below it
2023-05-07 20:29:33 -04:00
| n < 1 = throwError $ InsertException [PatternError s b r ZeroRepeats]
| otherwise = return $ min (s + b * (n - 1)) upper
2023-02-02 23:18:36 -05:00
dayToWeekday :: Day -> Int
dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7
2023-01-30 21:47:17 -05:00
withDates
2023-05-07 20:29:33 -04:00
:: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
2023-01-30 21:47:17 -05:00
=> DatePat
2023-05-07 20:29:33 -04:00
-> (Day -> m a)
-> m [a]
2023-01-30 21:47:17 -05:00
withDates dp f = do
2023-05-07 20:29:33 -04:00
bounds <- askDBState kmBudgetInterval
days <- liftExcept $ expandDatePat bounds dp
combineErrors $ fmap f days
2023-01-30 21:47:17 -05:00
2023-05-14 19:20:10 -04:00
foldDates
:: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
=> DatePat
-> Day
-> (Day -> Day -> m a)
-> m [a]
foldDates dp start f = do
bounds <- askDBState kmBudgetInterval
days <- liftExcept $ expandDatePat bounds dp
combineErrors $
snd $
L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days
2022-12-11 17:51:11 -05:00
--------------------------------------------------------------------------------
-- budget
2023-02-12 17:00:29 -05:00
-- each budget (designated at the top level by a 'name') is processed in the
-- following steps
-- 1. expand all transactions given the desired date range and date patterns for
-- each directive in the budget
-- 2. sort all transactions by date
-- 3. propagate all balances forward, and while doing so assign values to each
-- transaction (some of which depend on the 'current' balance of the
-- target account)
-- 4. assign shadow transactions (TODO)
-- 5. insert all transactions
2023-05-13 13:53:43 -04:00
insertBudget
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> Budget
2023-05-16 23:12:29 -04:00
-> m ()
insertBudget
b@Budget
2023-04-30 23:28:16 -04:00
{ bgtLabel
, bgtIncomes
, bgtTransfers
, bgtShadowTransfers
, bgtPretax
, bgtTax
, bgtPosttax
} =
2023-05-16 23:12:29 -04:00
whenHash CTBudget b () $ \key -> do
2023-05-07 20:29:33 -04:00
intAllos <- combineError3 pre_ tax_ post_ (,,)
2023-05-13 13:53:43 -04:00
let res1 = mapErrors (insertIncome key bgtLabel intAllos) bgtIncomes
2023-05-07 20:29:33 -04:00
let res2 = expandTransfers key bgtLabel bgtTransfers
txs <- combineError (concat <$> res1) res2 (++)
m <- askDBState kmCurrency
shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
2023-05-13 13:53:43 -04:00
void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow
where
2023-05-07 20:29:33 -04:00
pre_ = sortAllos bgtPretax
tax_ = sortAllos bgtTax
post_ = sortAllos bgtPosttax
sortAllos = liftExcept . combineErrors . fmap sortAllo
type BoundAllocation = Allocation (Day, Day)
type IntAllocations =
( [BoundAllocation PretaxValue]
, [BoundAllocation TaxValue]
, [BoundAllocation PosttaxValue]
)
-- TODO this should actually error if there is no ultimate end date?
2023-05-07 20:29:33 -04:00
sortAllo :: MultiAllocation v -> InsertExcept (BoundAllocation v)
sortAllo a@Allocation {alloAmts = as} = do
2023-05-16 23:12:29 -04:00
bs <- foldBounds [] $ L.sortOn amtWhen as
return $ a {alloAmts = reverse bs}
where
2023-05-16 23:12:29 -04:00
foldBounds acc [] = return acc
foldBounds acc (x : xs) = do
let start = amtWhen x
res <- case xs of
[] -> resolveBounds start
(y : _) -> resolveBounds_ (intStart $ amtWhen y) start
foldBounds (x {amtWhen = expandBounds res} : acc) xs
2023-02-13 19:57:39 -05:00
-- TODO this is going to be O(n*m), which might be a problem?
addShadowTransfers
2023-05-04 21:48:21 -04:00
:: CurrencyMap
-> [ShadowTransfer]
-> [UnbalancedTransfer]
2023-05-07 20:29:33 -04:00
-> InsertExcept [UnbalancedTransfer]
2023-05-04 21:48:21 -04:00
addShadowTransfers cm ms txs =
2023-02-13 19:57:39 -05:00
fmap catMaybes $
2023-05-07 20:29:33 -04:00
combineErrors $
2023-05-04 21:48:21 -04:00
fmap (uncurry (fromShadow cm)) $
2023-02-13 19:57:39 -05:00
[(t, m) | t <- txs, m <- ms]
fromShadow
2023-05-04 21:48:21 -04:00
:: CurrencyMap
-> UnbalancedTransfer
-> ShadowTransfer
2023-05-07 20:29:33 -04:00
-> InsertExcept (Maybe UnbalancedTransfer)
2023-05-04 21:48:21 -04:00
fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
2023-02-13 19:57:39 -05:00
res <- shadowMatches (stMatch t) tx
2023-05-04 21:48:21 -04:00
v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio
2023-02-13 19:57:39 -05:00
return $
if not res
then Nothing
else
Just $
-- TODO does this actually share the same metadata as the "parent" tx?
FlatTransfer
{ cbtMeta = cbtMeta tx
, cbtWhen = cbtWhen tx
, cbtCur = stCurrency
, cbtFrom = stFrom
, cbtTo = stTo
2023-05-04 21:48:21 -04:00
, cbtValue = UnbalancedValue stType $ v * cvValue (cbtValue tx)
, cbtDesc = stDesc
2023-02-13 19:57:39 -05:00
}
2023-05-07 20:29:33 -04:00
shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool
2023-04-30 23:28:16 -04:00
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
valRes <- valMatches tmVal $ cvValue $ cbtValue tx
2023-02-13 19:57:39 -05:00
return $
2023-04-30 23:28:16 -04:00
memberMaybe (taAcnt $ cbtFrom tx) tmFrom
&& memberMaybe (taAcnt $ cbtTo tx) tmTo
&& maybe True (`dateMatches` cbtWhen tx) tmDate
2023-02-13 19:57:39 -05:00
&& valRes
where
memberMaybe x AcntSet {asList, asInclude} =
(if asInclude then id else not) $ x `elem` asList
2022-12-11 17:51:11 -05:00
balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
2023-05-16 23:12:29 -04:00
balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn cbtWhen
2023-02-12 22:18:31 -05:00
where
go bals f@FlatTransfer {cbtFrom, cbtTo, cbtValue = UnbalancedValue {cvValue, cvType}} =
2023-05-16 23:12:29 -04:00
let balTo = M.findWithDefault 0 cbtTo bals
x = amtToMove balTo cvType cvValue
bals' = mapAdd_ cbtTo x $ mapAdd_ cbtFrom (-x) bals
in (bals', f {cbtValue = x})
2023-02-12 22:18:31 -05:00
-- TODO might need to query signs to make this intuitive; as it is this will
-- probably work, but for credit accounts I might need to supply a negative
-- target value
amtToMove _ BTFixed x = x
amtToMove bal BTPercent x = -(x / 100 * bal)
amtToMove bal BTTarget x = x - bal
mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
2023-05-16 23:12:29 -04:00
mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
2023-02-12 22:18:31 -05:00
data BudgetMeta = BudgetMeta
{ bmCommit :: !CommitRId
2023-02-05 18:45:56 -05:00
, bmName :: !T.Text
}
2023-04-12 22:58:31 -04:00
deriving (Show)
data FlatTransfer v = FlatTransfer
{ cbtFrom :: !TaggedAcnt
, cbtTo :: !TaggedAcnt
, cbtValue :: !v
, cbtWhen :: !Day
, cbtDesc :: !T.Text
, cbtMeta :: !BudgetMeta
, cbtCur :: !BudgetCurrency
}
2023-05-13 13:53:43 -04:00
deriving (Show)
data UnbalancedValue = UnbalancedValue
{ cvType :: !BudgetTransferType
, cvValue :: !Rational
2023-02-12 16:52:42 -05:00
}
2023-05-13 13:53:43 -04:00
deriving (Show)
type UnbalancedTransfer = FlatTransfer UnbalancedValue
type BalancedTransfer = FlatTransfer Rational
2023-02-12 16:52:42 -05:00
insertIncome
2023-05-07 20:29:33 -04:00
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> CommitRId
-> T.Text
-> IntAllocations
-> Income
2023-05-07 20:29:33 -04:00
-> m [UnbalancedTransfer]
2023-02-12 16:23:32 -05:00
insertIncome
key
2023-02-12 16:23:32 -05:00
name
(intPre, intTax, intPost)
2023-05-14 19:20:10 -04:00
Income
{ incWhen
, incCurrency
, incFrom
, incPretax
, incPosttax
, incTaxes
, incToBal
, incGross
, incPayPeriod
} = do
-- TODO check that the other accounts are not income somewhere here
2023-05-07 20:29:33 -04:00
_ <- checkAcntType IncomeT $ taAcnt incFrom
precision <- lookupCurrencyPrec incCurrency
2023-05-14 19:20:10 -04:00
let gross = roundPrecision precision incGross
2023-05-07 20:29:33 -04:00
-- TODO this will scan the interval allocations fully each time
-- iteration which is a total waste, but the fix requires turning this
-- loop into a fold which I don't feel like doing now :(
2023-05-14 19:20:10 -04:00
res <- foldDates incWhen start (allocate precision gross)
2023-05-07 20:29:33 -04:00
return $ concat res
where
2023-05-14 19:20:10 -04:00
start = fromGregorian' $ pStart incPayPeriod
pType' = pType incPayPeriod
meta = BudgetMeta key name
flatPre = concatMap flattenAllo incPretax
flatTax = concatMap flattenAllo incTaxes
flatPost = concatMap flattenAllo incPosttax
sumAllos = sum . fmap faValue
-- TODO ensure these are all the "correct" accounts
2023-05-14 19:20:10 -04:00
allocate precision gross prevDay day = do
scaler <- liftExcept $ periodScaler pType' prevDay day
let (preDeductions, pre) =
2023-05-04 21:48:21 -04:00
allocatePre precision gross $
flatPre ++ concatMap (selectAllos day) intPre
tax =
2023-05-14 19:20:10 -04:00
allocateTax precision gross preDeductions scaler $
flatTax ++ concatMap (selectAllos day) intTax
aftertaxGross = sumAllos $ tax ++ pre
post =
2023-05-04 21:48:21 -04:00
allocatePost precision aftertaxGross $
flatPost ++ concatMap (selectAllos day) intPost
balance = aftertaxGross - sumAllos post
bal =
FlatTransfer
{ cbtMeta = meta
, cbtWhen = day
, cbtFrom = incFrom
, cbtCur = NoX incCurrency
, cbtTo = incToBal
, cbtValue = UnbalancedValue BTFixed balance
, cbtDesc = "balance after deductions"
}
in if balance < 0
2023-05-07 20:29:33 -04:00
then throwError $ InsertException [IncomeError day name balance]
else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post))
2023-05-14 19:20:10 -04:00
type PeriodScaler = Natural -> Double -> Double
-- TODO we probably don't need to check for 1/0 each time
periodScaler
:: PeriodType
-> Day
-> Day
-> InsertExcept PeriodScaler
2023-05-16 23:12:29 -04:00
periodScaler pt prev cur = do
n <- workingDays wds prev cur
return $ scale (fromIntegral n)
2023-05-14 19:20:10 -04:00
where
2023-05-16 23:12:29 -04:00
wds = case pt of
Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
Daily ds -> ds
scale n precision x = case pt of
2023-05-14 19:20:10 -04:00
Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
fromRational (rnd $ x / fromIntegral hpAnnualHours)
* fromIntegral hpDailyHours
* n
Daily _ -> x * n / 365.25
where
rnd = roundPrecision precision
2023-05-16 23:12:29 -04:00
workingDays :: [Weekday] -> Day -> Day -> InsertExcept Natural
workingDays wds start end
| interval > 0 =
let (nFull, nPart) = divMod interval 7
daysFull = fromIntegral (length wds') * nFull
daysTail = fromIntegral $ length $ takeWhile (< nPart) wds'
in return $ fromIntegral $ daysFull + daysTail
| otherwise = throwError $ InsertException undefined
where
interval = diffDays end start
startDay = dayOfWeek start
wds' = L.sort $ (\x -> diff (fromWeekday x) startDay) <$> L.nub wds
diff a b = fromIntegral $ mod (fromEnum a - fromEnum b) 7
allocatePre
2023-05-04 21:48:21 -04:00
:: Natural
-> Rational
-> [FlatAllocation PretaxValue]
-> (M.Map T.Text Rational, [FlatAllocation Rational])
2023-05-04 21:48:21 -04:00
allocatePre precision gross = L.mapAccumR go M.empty
where
go m f@FlatAllocation {faValue} =
let c = preCategory faValue
2023-05-04 21:48:21 -04:00
p = preValue faValue
v =
if prePercent faValue
2023-05-08 00:12:01 -04:00
then (roundPrecision 3 p / 100) * gross
2023-05-04 21:48:21 -04:00
else roundPrecision precision p
in (mapAdd_ c v m, f {faValue = v})
allo2Trans
:: BudgetMeta
-> Day
2023-02-26 22:53:12 -05:00
-> TaggedAcnt
-> FlatAllocation Rational
-> UnbalancedTransfer
allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
FlatTransfer
{ cbtMeta = meta
, cbtWhen = day
, cbtFrom = from
, cbtCur = faCur
, cbtTo = faTo
, cbtValue = UnbalancedValue BTFixed faValue
, cbtDesc = faDesc
}
allocateTax
2023-05-04 21:48:21 -04:00
:: Natural
-> Rational
-> M.Map T.Text Rational
2023-05-14 19:20:10 -04:00
-> PeriodScaler
-> [FlatAllocation TaxValue]
-> [FlatAllocation Rational]
2023-05-14 19:20:10 -04:00
allocateTax precision gross preDeds f = fmap (fmap go)
where
go TaxValue {tvCategories, tvMethod} =
2023-05-14 19:20:10 -04:00
let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories)
in case tvMethod of
2023-05-16 23:12:29 -04:00
TMPercent p ->
roundPrecision precision $
fromRational $
roundPrecision 3 p / 100 * agi
2023-04-30 23:28:16 -04:00
TMBracket TaxProgression {tpDeductible, tpBrackets} ->
2023-05-14 19:20:10 -04:00
let taxDed = roundPrecision precision $ f precision tpDeductible
in foldBracket f precision (agi - taxDed) tpBrackets
allocatePost
2023-05-04 21:48:21 -04:00
:: Natural
-> Rational
-> [FlatAllocation PosttaxValue]
-> [FlatAllocation Rational]
2023-05-04 21:48:21 -04:00
allocatePost precision aftertax = fmap (fmap go)
where
go PosttaxValue {postValue, postPercent} =
2023-05-08 00:12:01 -04:00
let v = postValue
in if postPercent
then aftertax * roundPrecision 3 v / 100
else roundPrecision precision v
2023-01-27 20:31:13 -05:00
2023-05-16 23:12:29 -04:00
-- | Compute effective tax percentage of a bracket
-- The algorithm can be thought of in three phases:
-- 1. Find the highest tax bracket by looping backward until the AGI is less
-- than the bracket limit
-- 2. Computing the tax in the top bracket by subtracting the AGI from the
-- bracket limit and multiplying by the tax percentage.
-- 3. Adding all lower brackets, which are just the limit of the bracket less
-- the amount of the lower bracket times the percentage.
--
-- In reality, this can all be done with one loop, but it isn't clear these
-- three steps are implemented from this alone.
2023-05-14 19:20:10 -04:00
foldBracket :: PeriodScaler -> Natural -> Rational -> [TaxBracket] -> Rational
foldBracket f precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
where
2023-05-16 23:12:29 -04:00
go TaxBracket {tbLowerLimit, tbPercent} a@(acc, remain) =
2023-05-14 19:20:10 -04:00
let l = roundPrecision precision $ f precision tbLowerLimit
2023-05-08 00:12:01 -04:00
p = roundPrecision 3 tbPercent / 100
2023-05-16 23:12:29 -04:00
in if remain >= l then (acc + p * (remain - l), l) else a
data FlatAllocation v = FlatAllocation
{ faValue :: !v
, faDesc :: !T.Text
, faTo :: !TaggedAcnt
, faCur :: !BudgetCurrency
}
2023-05-16 23:12:29 -04:00
deriving (Functor, Show)
2022-12-11 17:51:11 -05:00
flattenAllo :: SingleAllocation v -> [FlatAllocation v]
flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
where
go Amount {amtValue, amtDesc} =
FlatAllocation
{ faCur = NoX alloCur
, faTo = alloTo
, faValue = amtValue
, faDesc = amtDesc
}
2022-12-11 17:51:11 -05:00
-- ASSUME allocations are sorted
selectAllos :: Day -> BoundAllocation v -> [FlatAllocation v]
selectAllos day Allocation {alloAmts, alloCur, alloTo} =
2023-05-16 23:12:29 -04:00
go <$> filter ((`inBounds` day) . amtWhen) alloAmts
where
go Amount {amtValue, amtDesc} =
FlatAllocation
{ faCur = NoX alloCur
, faTo = alloTo
, faValue = amtValue
, faDesc = amtDesc
}
2022-12-11 17:51:11 -05:00
2023-02-12 22:18:31 -05:00
expandTransfers
2023-05-07 20:29:33 -04:00
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> CommitRId
-> T.Text
-> [BudgetTransfer]
2023-05-07 20:29:33 -04:00
-> m [UnbalancedTransfer]
expandTransfers key name ts =
fmap (L.sortOn cbtWhen . concat) $
combineErrors $
fmap (expandTransfer key name) ts
2023-02-12 16:23:32 -05:00
2023-05-04 21:48:21 -04:00
initialCurrency :: BudgetCurrency -> CurID
initialCurrency (NoX c) = c
initialCurrency (X Exchange {xFromCur = c}) = c
expandTransfer
2023-05-07 20:29:33 -04:00
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> CommitRId
-> T.Text
-> BudgetTransfer
2023-05-07 20:29:33 -04:00
-> m [UnbalancedTransfer]
2023-05-04 21:48:21 -04:00
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do
2023-05-07 20:29:33 -04:00
precision <- lookupCurrencyPrec $ initialCurrency transCurrency
fmap concat $ combineErrors $ fmap (go precision) transAmounts
where
go
precision
Amount
{ amtWhen = pat
, amtValue = BudgetTransferValue {btVal = v, btType = y}
, amtDesc = desc
} =
withDates pat $ \day -> do
let meta = BudgetMeta {bmCommit = key, bmName = name}
return
FlatTransfer
{ cbtMeta = meta
, cbtWhen = day
, cbtCur = transCurrency
, cbtFrom = transFrom
, cbtTo = transTo
, cbtValue = UnbalancedValue y $ roundPrecision precision v
, cbtDesc = desc
}
insertBudgetTx :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => BalancedTransfer -> m ()
insertBudgetTx FlatTransfer {cbtFrom, cbtTo, cbtMeta, cbtCur, cbtValue, cbtDesc, cbtWhen} = do
2023-05-07 20:29:33 -04:00
((sFrom, sTo), exchange) <- splitPair cbtFrom cbtTo cbtCur cbtValue
insertPair sFrom sTo
forM_ exchange $ uncurry insertPair
2023-02-05 18:45:56 -05:00
where
2023-02-26 12:03:35 -05:00
insertPair from to = do
k <- insert $ TransactionR (bmCommit cbtMeta) cbtWhen cbtDesc
2023-02-26 18:57:40 -05:00
insertBudgetLabel k from
insertBudgetLabel k to
insertBudgetLabel k split = do
sk <- insertSplit k split
insert_ $ BudgetLabelR sk $ bmName cbtMeta
2023-01-30 21:47:17 -05:00
2023-02-26 12:03:35 -05:00
type SplitPair = (KeySplit, KeySplit)
2023-01-30 21:47:17 -05:00
splitPair
2023-05-07 20:29:33 -04:00
:: (MonadInsertError m, MonadFinance m)
2023-02-26 22:53:12 -05:00
=> TaggedAcnt
-> TaggedAcnt
2023-02-26 12:03:35 -05:00
-> BudgetCurrency
2023-01-30 21:47:17 -05:00
-> Rational
2023-05-07 20:29:33 -04:00
-> m (SplitPair, Maybe SplitPair)
2023-02-26 12:03:35 -05:00
splitPair from to cur val = case cur of
2023-05-07 20:29:33 -04:00
NoX curid -> (,Nothing) <$> pair curid from to val
X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
2023-02-26 22:53:12 -05:00
let middle = TaggedAcnt xAcnt []
2023-05-07 20:29:33 -04:00
let res1 = pair xFromCur from middle val
let res2 = pair xToCur middle to (val * roundPrecision 3 xRate)
combineError res1 res2 $ \a b -> (a, Just b)
2023-01-30 21:47:17 -05:00
where
2023-02-26 12:03:35 -05:00
pair curid from_ to_ v = do
2023-05-07 20:29:33 -04:00
let s1 = split curid from_ (-v)
let s2 = split curid to_ v
combineError s1 s2 (,)
2023-02-26 22:53:12 -05:00
split c TaggedAcnt {taAcnt, taTags} v =
2023-01-30 21:47:17 -05:00
resolveSplit $
Entry
2023-04-30 23:28:16 -04:00
{ eAcnt = taAcnt
, eValue = v
, eComment = ""
, eCurrency = c
, eTags = taTags
2023-01-30 21:47:17 -05:00
}
2023-02-12 22:18:31 -05:00
checkAcntType
2023-05-07 20:29:33 -04:00
:: (MonadInsertError m, MonadFinance m)
2023-02-12 22:18:31 -05:00
=> AcntType
-> AcntID
2023-05-07 20:29:33 -04:00
-> m AcntID
2023-02-12 22:18:31 -05:00
checkAcntType t = checkAcntTypes (t :| [])
checkAcntTypes
2023-05-07 20:29:33 -04:00
:: (MonadInsertError m, MonadFinance m)
2023-02-12 22:18:31 -05:00
=> NE.NonEmpty AcntType
-> AcntID
2023-05-07 20:29:33 -04:00
-> m AcntID
checkAcntTypes ts i = go =<< lookupAccountType i
2023-02-12 22:18:31 -05:00
where
go t
2023-05-07 20:29:33 -04:00
| t `L.elem` ts = return i
| otherwise = throwError $ InsertException [AccountError i ts]
2023-02-12 22:18:31 -05:00
2022-12-11 17:51:11 -05:00
--------------------------------------------------------------------------------
-- statements
2023-05-13 13:53:43 -04:00
splitHistory :: [History] -> ([HistTransfer], [Statement])
splitHistory = partitionEithers . fmap go
where
go (HistTransfer x) = Left x
go (HistStatement x) = Right x
-- insertStatement
-- :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
-- => History
-- -> m ()
-- insertStatement (HistTransfer m) = liftIOExceptT $ insertManual m
-- insertStatement (HistStatement i) = insertImport i
2022-12-11 17:51:11 -05:00
2023-05-13 13:53:43 -04:00
insertHistTransfer
2023-05-07 20:29:33 -04:00
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> HistTransfer
-> m ()
2023-05-13 13:53:43 -04:00
insertHistTransfer
m@Transfer
{ transFrom = from
, transTo = to
, transCurrency = u
, transAmounts = amts
} = do
2023-05-07 20:29:33 -04:00
whenHash CTManual m () $ \c -> do
bounds <- askDBState kmStatementInterval
let precRes = lookupCurrencyPrec u
let go Amount {amtWhen, amtValue, amtDesc} = do
let dayRes = liftExcept $ expandDatePat bounds amtWhen
(days, precision) <- combineError dayRes precRes (,)
let tx day = txPair day from to u (roundPrecision precision amtValue) amtDesc
keys <- combineErrors $ fmap tx days
mapM_ (insertTx c) keys
void $ combineErrors $ fmap go amts
2023-05-13 13:53:43 -04:00
readHistStmt :: (MonadUnliftIO m, MonadFinance m) => Statement -> m (Maybe (CommitR, [KeyTx]))
readHistStmt i = whenHash_ CTImport i $ do
2023-05-07 20:29:33 -04:00
bs <- readImport i
bounds <- expandBounds <$> askDBState kmStatementInterval
2023-05-13 13:53:43 -04:00
liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs
insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m ()
insertHistStmt c ks = do
ck <- insert c
mapM_ (insertTx ck) ks
-- insertImport
-- :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
-- => Statement
-- -> m ()
-- insertImport i = whenHash CTImport i () $ \c -> do
-- -- TODO this isn't efficient, the whole file will be read and maybe no
-- -- transactions will be desired
-- bs <- readImport i
-- bounds <- expandBounds <$> askDBState kmStatementInterval
-- keys <- liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs
-- mapM_ (insertTx c) keys
2022-12-11 17:51:11 -05:00
--------------------------------------------------------------------------------
-- low-level transaction stuff
2023-02-26 22:53:12 -05:00
-- TODO tags here?
txPair
2023-05-07 20:29:33 -04:00
:: (MonadInsertError m, MonadFinance m)
=> Day
-> AcntID
-> AcntID
-> CurID
-> Rational
-> T.Text
2023-05-07 20:29:33 -04:00
-> m KeyTx
2022-12-11 17:51:11 -05:00
txPair day from to cur val desc = resolveTx tx
where
2023-04-30 23:28:16 -04:00
split a v =
Entry
{ eAcnt = a
, eValue = v
, eComment = ""
, eCurrency = cur
, eTags = []
}
tx =
Tx
{ txDescr = desc
, txDate = day
, txSplits = [split from (-val), split to val]
}
2022-12-11 17:51:11 -05:00
2023-05-07 20:29:33 -04:00
resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
resolveTx t@Tx {txSplits = ss} =
fmap (\kss -> t {txSplits = kss}) $
combineErrors $
fmap resolveSplit ss
2022-12-11 17:51:11 -05:00
2023-05-07 20:29:33 -04:00
resolveSplit :: (MonadInsertError m, MonadFinance m) => BalSplit -> m KeySplit
2023-04-30 23:28:16 -04:00
resolveSplit s@Entry {eAcnt, eCurrency, eValue, eTags} = do
2023-05-07 20:29:33 -04:00
let aRes = lookupAccountKey eAcnt
let cRes = lookupCurrencyKey eCurrency
let sRes = lookupAccountSign eAcnt
let tagRes = combineErrors $ fmap lookupTag eTags
2022-12-11 17:51:11 -05:00
-- TODO correct sign here?
-- TODO lenses would be nice here
2023-05-07 20:29:33 -04:00
combineError (combineError3 aRes cRes sRes (,,)) tagRes $
\(aid, cid, sign) tags ->
s
{ eAcnt = aid
, eCurrency = cid
, eValue = eValue * fromIntegral (sign2Int sign)
, eTags = tags
}
2023-01-28 22:55:07 -05:00
2023-05-07 20:29:33 -04:00
insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
2023-01-30 21:47:17 -05:00
insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do
k <- insert $ TransactionR c d e
2022-12-11 17:51:11 -05:00
mapM_ (insertSplit k) ss
2023-05-07 20:29:33 -04:00
insertSplit :: MonadSqlQuery m => TransactionRId -> KeySplit -> m SplitRId
2023-04-30 23:28:16 -04:00
insertSplit t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
k <- insert $ SplitR t eCurrency eAcnt eComment eValue
mapM_ (insert_ . TagRelationR k) eTags
2023-02-26 22:53:12 -05:00
return k
2023-01-28 22:55:07 -05:00
2023-05-07 20:29:33 -04:00
lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntSign, AcntType)
lookupAccount = lookupFinance AcntField kmAccount
2023-02-12 21:52:41 -05:00
2023-05-07 20:29:33 -04:00
lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId
lookupAccountKey = fmap fstOf3 . lookupAccount
2023-01-28 22:55:07 -05:00
2023-05-07 20:29:33 -04:00
lookupAccountSign :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntSign
lookupAccountSign = fmap sndOf3 . lookupAccount
2023-01-28 22:55:07 -05:00
2023-05-07 20:29:33 -04:00
lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType
lookupAccountType = fmap thdOf3 . lookupAccount
2023-01-28 22:55:07 -05:00
2023-05-07 20:29:33 -04:00
lookupCurrency :: (MonadInsertError m, MonadFinance m) => T.Text -> m (CurrencyRId, Natural)
lookupCurrency = lookupFinance CurField kmCurrency
2023-02-12 16:52:42 -05:00
2023-05-07 20:29:33 -04:00
lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId
lookupCurrencyKey = fmap fst . lookupCurrency
2023-05-04 21:48:21 -04:00
2023-05-07 20:29:33 -04:00
lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Natural
lookupCurrencyPrec = fmap snd . lookupCurrency
2023-05-04 21:48:21 -04:00
2023-05-07 20:29:33 -04:00
lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
lookupTag = lookupFinance TagField kmTag
lookupFinance
:: (MonadInsertError m, MonadFinance m)
=> SplitIDType
-> (DBState -> M.Map T.Text a)
-> T.Text
-> m a
lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f
2023-02-26 22:53:12 -05:00
2023-02-12 16:52:42 -05:00
-- TODO this hashes twice (not that it really matters)
2023-05-07 20:29:33 -04:00
2023-02-12 16:52:42 -05:00
whenHash
2023-05-07 20:29:33 -04:00
:: (Hashable a, MonadFinance m, MonadSqlQuery m)
2023-02-12 16:52:42 -05:00
=> ConfigType
-> a
-> b
2023-05-07 20:29:33 -04:00
-> (CommitRId -> m b)
-> m b
2023-02-12 16:52:42 -05:00
whenHash t o def f = do
let h = hash o
2023-05-07 20:29:33 -04:00
hs <- askDBState kmNewCommits
2023-02-12 16:52:42 -05:00
if h `elem` hs then f =<< insert (CommitR h t) else return def
2023-05-13 13:53:43 -04:00
whenHash_
:: (Hashable a, MonadFinance m)
=> ConfigType
-> a
-> m b
-> m (Maybe (CommitR, b))
whenHash_ t o f = do
let h = hash o
let c = CommitR h t
hs <- askDBState kmNewCommits
if h `elem` hs then Just . (c,) <$> f else return Nothing