653 lines
22 KiB
Haskell
653 lines
22 KiB
Haskell
module Internal.Insert
|
|
( insertStatements
|
|
, insertBudget
|
|
)
|
|
where
|
|
|
|
import Data.Hashable
|
|
import Database.Persist.Class
|
|
import Database.Persist.Sql hiding (Single, Statement)
|
|
import Internal.Statement
|
|
import Internal.Types hiding (sign)
|
|
import Internal.Utils
|
|
import RIO hiding (to)
|
|
import qualified RIO.List as L
|
|
import qualified RIO.Map as M
|
|
import qualified RIO.NonEmpty as NE
|
|
import qualified RIO.Text as T
|
|
import RIO.Time
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- intervals
|
|
|
|
expandDatePat :: Bounds -> DatePat -> EitherErrs [Day]
|
|
expandDatePat b (Cron cp) = expandCronPat b cp
|
|
expandDatePat i (Mod mp) = Right $ expandModPat mp i
|
|
|
|
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 ..]
|
|
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
|
|
|
|
expandCronPat :: Bounds -> CronPat -> EitherErrs [Day]
|
|
expandCronPat b CronPat {cronYear, cronMonth, cronDay, cronWeekly} =
|
|
concatEither3 yRes mRes dRes $ \ys ms ds ->
|
|
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]
|
|
where
|
|
yRes = case cronYear of
|
|
Nothing -> return [yb0 .. yb1]
|
|
Just pat -> do
|
|
ys <- expandMDYPat (fromIntegral yb0) (fromIntegral yb1) pat
|
|
return $ dropWhile (< yb0) $ fromIntegral <$> ys
|
|
mRes = expandMD 12 cronMonth
|
|
dRes = expandMD 31 cronDay
|
|
(s, e) = expandBounds b
|
|
(yb0, mb0, db0) = toGregorian s
|
|
(yb1, mb1, db1) = toGregorian $ addDays (-1) e
|
|
expandMD lim =
|
|
fmap (fromIntegral <$>)
|
|
. maybe (return [1 .. lim]) (expandMDYPat 1 lim)
|
|
expandW (OnDay x) = [fromEnum x]
|
|
expandW (OnDays xs) = fromEnum <$> xs
|
|
ws = maybe [] expandW cronWeekly
|
|
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
|
|
|
|
expandMDYPat :: Natural -> Natural -> MDYPat -> EitherErr [Natural]
|
|
expandMDYPat lower upper (Single x) = Right [x | lower <= x && x <= upper]
|
|
expandMDYPat lower upper (Multi xs) = Right $ dropWhile (<= lower) $ takeWhile (<= upper) xs
|
|
expandMDYPat lower upper (After x) = Right [max lower x .. upper]
|
|
expandMDYPat lower upper (Before x) = Right [lower .. min upper x]
|
|
expandMDYPat lower upper (Between x y) = Right [max lower x .. min upper y]
|
|
expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r})
|
|
| b < 1 = Left $ PatternError s b r ZeroLength
|
|
| otherwise = do
|
|
k <- limit r
|
|
return $ dropWhile (<= lower) $ takeWhile (<= k) [s + i * b | i <- [0 ..]]
|
|
where
|
|
limit Nothing = Right upper
|
|
limit (Just n)
|
|
-- this guard not only produces the error for the user but also protects
|
|
-- from an underflow below it
|
|
| n < 1 = Left $ PatternError s b r ZeroRepeats
|
|
| otherwise = Right $ min (s + b * (n - 1)) upper
|
|
|
|
dayToWeekday :: Day -> Int
|
|
dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7
|
|
|
|
withDates
|
|
:: MonadFinance m
|
|
=> DatePat
|
|
-> (Day -> SqlPersistT m (EitherErrs a))
|
|
-> SqlPersistT m (EitherErrs [a])
|
|
withDates dp f = do
|
|
bounds <- lift $ askDBState kmBudgetInterval
|
|
case expandDatePat bounds dp of
|
|
Left es -> return $ Left es
|
|
Right days -> concatEithersL <$> mapM f days
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- budget
|
|
|
|
-- 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
|
|
|
|
insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError]
|
|
insertBudget
|
|
b@Budget
|
|
{ budgetLabel
|
|
, incomes
|
|
, transfers
|
|
, shadowTransfers
|
|
, pretax
|
|
, tax
|
|
, posttax
|
|
} =
|
|
whenHash CTBudget b [] $ \key -> do
|
|
unlessLefts intAllos $ \intAllos_ -> do
|
|
res1 <- mapM (insertIncome key budgetLabel intAllos_) incomes
|
|
res2 <- expandTransfers key budgetLabel transfers
|
|
unlessLefts (concatEithers2 (concat <$> concatEithersL res1) res2 (++)) $
|
|
\txs -> do
|
|
unlessLefts (addShadowTransfers shadowTransfers txs) $ \shadow -> do
|
|
let bals = balanceTransfers $ txs ++ shadow
|
|
concat <$> mapM insertBudgetTx bals
|
|
where
|
|
intAllos =
|
|
let pre_ = sortAllos pretax
|
|
tax_ = sortAllos tax
|
|
post_ = sortAllos posttax
|
|
in concatEithers3 pre_ tax_ post_ (,,)
|
|
sortAllos = concatEithersL . 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?
|
|
sortAllo :: MultiAllocation v -> EitherErrs (BoundAllocation v)
|
|
sortAllo a@Allocation {alloAmts = as} = do
|
|
bs <- foldBounds (Right []) $ L.sortOn amtWhen as
|
|
return $ a {alloAmts = reverse bs}
|
|
where
|
|
foldBounds acc [] = acc
|
|
foldBounds acc (x : xs) =
|
|
let res = case xs of
|
|
[] -> resolveBounds $ amtWhen x
|
|
(y : _) -> resolveBounds_ (intStart $ amtWhen y) $ amtWhen x
|
|
concatRes bs acc' = x {amtWhen = expandBounds bs} : acc'
|
|
in foldBounds (concatEithers2 (plural res) acc concatRes) xs
|
|
|
|
-- TODO this is going to be O(n*m), which might be a problem?
|
|
addShadowTransfers
|
|
:: [ShadowTransfer]
|
|
-> [UnbalancedTransfer]
|
|
-> EitherErrs [UnbalancedTransfer]
|
|
addShadowTransfers ms txs =
|
|
fmap catMaybes $
|
|
concatEitherL $
|
|
fmap (uncurry fromShadow) $
|
|
[(t, m) | t <- txs, m <- ms]
|
|
|
|
fromShadow
|
|
:: UnbalancedTransfer
|
|
-> ShadowTransfer
|
|
-> EitherErr (Maybe UnbalancedTransfer)
|
|
fromShadow tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
|
|
res <- shadowMatches (stMatch t) tx
|
|
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
|
|
, cbtValue = UnbalancedValue stType $ dec2Rat stRatio * cvValue (cbtValue tx)
|
|
, cbtDesc = stDesc
|
|
}
|
|
|
|
shadowMatches :: TransferMatcher -> UnbalancedTransfer -> EitherErr Bool
|
|
shadowMatches TransferMatcher {smFrom, smTo, smDate, smVal} tx = do
|
|
valRes <- valMatches smVal $ cvValue $ cbtValue tx
|
|
return $
|
|
memberMaybe (taAcnt $ cbtFrom tx) smFrom
|
|
&& memberMaybe (taAcnt $ cbtTo tx) smTo
|
|
&& maybe True (`dateMatches` cbtWhen tx) smDate
|
|
&& valRes
|
|
where
|
|
memberMaybe x AcntSet {asList, asInclude} =
|
|
(if asInclude then id else not) $ x `elem` asList
|
|
|
|
balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
|
|
balanceTransfers ts =
|
|
snd $ L.mapAccumR go M.empty $ reverse $ L.sortOn cbtWhen ts
|
|
where
|
|
go bals f@FlatTransfer {cbtFrom, cbtTo, cbtValue = UnbalancedValue {cvValue, cvType}} =
|
|
let (bals', v) = mapAdd cbtTo x $ mapAdd_ cbtFrom (-x) bals
|
|
x = amtToMove v cvType cvValue
|
|
in (bals', f {cbtValue = x})
|
|
-- 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
|
|
mapAdd_ k v m = fst $ mapAdd k v m
|
|
|
|
mapAdd :: (Ord k, Num v) => k -> v -> M.Map k v -> (M.Map k v, v)
|
|
mapAdd k v m = (new, M.findWithDefault (error "this should not happen") k new)
|
|
where
|
|
new = M.alter (maybe (Just v) (Just . (+ v))) k m
|
|
|
|
data BudgetMeta = BudgetMeta
|
|
{ bmCommit :: !CommitRId
|
|
, bmName :: !T.Text
|
|
}
|
|
deriving (Show)
|
|
|
|
data FlatTransfer v = FlatTransfer
|
|
{ cbtFrom :: !TaggedAcnt
|
|
, cbtTo :: !TaggedAcnt
|
|
, cbtValue :: !v
|
|
, cbtWhen :: !Day
|
|
, cbtDesc :: !T.Text
|
|
, cbtMeta :: !BudgetMeta
|
|
, cbtCur :: !BudgetCurrency
|
|
}
|
|
|
|
data UnbalancedValue = UnbalancedValue
|
|
{ cvType :: !BudgetTransferType
|
|
, cvValue :: !Rational
|
|
}
|
|
|
|
type UnbalancedTransfer = FlatTransfer UnbalancedValue
|
|
|
|
type BalancedTransfer = FlatTransfer Rational
|
|
|
|
insertIncome
|
|
:: MonadFinance m
|
|
=> CommitRId
|
|
-> T.Text
|
|
-> IntAllocations
|
|
-> Income
|
|
-> SqlPersistT m (EitherErrs [UnbalancedTransfer])
|
|
insertIncome
|
|
key
|
|
name
|
|
(intPre, intTax, intPost)
|
|
Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal, incGross} = do
|
|
-- TODO check that the other accounts are not income somewhere here
|
|
fromRes <- lift $ checkAcntType IncomeT $ taAcnt incFrom
|
|
case fromRes of
|
|
Left e -> return $ Left [e]
|
|
-- 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 :(
|
|
Right _ -> fmap concat <$> withDates incWhen (return . allocate)
|
|
where
|
|
meta = BudgetMeta key name
|
|
gross = dec2Rat incGross
|
|
flatPre = concatMap flattenAllo incPretax
|
|
flatTax = concatMap flattenAllo incTaxes
|
|
flatPost = concatMap flattenAllo incPosttax
|
|
sumAllos = sum . fmap faValue
|
|
-- TODO ensure these are all the "correct" accounts
|
|
allocate day =
|
|
let (preDeductions, pre) =
|
|
allocatePre gross $
|
|
flatPre ++ concatMap (selectAllos day) intPre
|
|
tax =
|
|
allocateTax gross preDeductions $
|
|
flatTax ++ concatMap (selectAllos day) intTax
|
|
aftertaxGross = sumAllos $ tax ++ pre
|
|
post =
|
|
allocatePost 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
|
|
then Left [IncomeError day name balance]
|
|
else Right $ bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post)
|
|
|
|
allocatePre
|
|
:: Rational
|
|
-> [FlatAllocation PretaxValue]
|
|
-> (M.Map T.Text Rational, [FlatAllocation Rational])
|
|
allocatePre gross = L.mapAccumR go M.empty
|
|
where
|
|
go m f@FlatAllocation {faValue} =
|
|
let c = preCategory faValue
|
|
p = dec2Rat $ preValue faValue
|
|
v = if prePercent faValue then p * gross else p
|
|
in (mapAdd_ c v m, f {faValue = v})
|
|
|
|
allo2Trans
|
|
:: BudgetMeta
|
|
-> Day
|
|
-> 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
|
|
:: Rational
|
|
-> M.Map T.Text Rational
|
|
-> [FlatAllocation TaxValue]
|
|
-> [FlatAllocation Rational]
|
|
allocateTax gross deds = fmap (fmap go)
|
|
where
|
|
go TaxValue {tvCategories, tvMethod} =
|
|
let agi = gross - sum (mapMaybe (`M.lookup` deds) tvCategories)
|
|
in case tvMethod of
|
|
TMPercent p -> dec2Rat p * agi
|
|
TMBracket TaxProgression {tbsDeductible, tbsBrackets} ->
|
|
foldBracket (agi - dec2Rat tbsDeductible) tbsBrackets
|
|
|
|
allocatePost
|
|
:: Rational
|
|
-> [FlatAllocation PosttaxValue]
|
|
-> [FlatAllocation Rational]
|
|
allocatePost aftertax = fmap (fmap go)
|
|
where
|
|
go PosttaxValue {postValue, postPercent} =
|
|
let v = dec2Rat postValue in if postPercent then aftertax * v else v
|
|
|
|
foldBracket :: Rational -> [TaxBracket] -> Rational
|
|
foldBracket agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
|
|
where
|
|
go TaxBracket {tbLowerLimit, tbPercent} (acc, remain) =
|
|
let l = dec2Rat tbLowerLimit
|
|
p = dec2Rat tbPercent
|
|
in if remain < l then (acc + p * (remain - l), l) else (acc, remain)
|
|
|
|
data FlatAllocation v = FlatAllocation
|
|
{ faValue :: !v
|
|
, faDesc :: !T.Text
|
|
, faTo :: !TaggedAcnt
|
|
, faCur :: !BudgetCurrency
|
|
}
|
|
deriving (Functor)
|
|
|
|
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
|
|
}
|
|
|
|
-- ASSUME allocations are sorted
|
|
selectAllos :: Day -> BoundAllocation v -> [FlatAllocation v]
|
|
selectAllos day Allocation {alloAmts, alloCur, alloTo} =
|
|
fmap go $
|
|
takeWhile ((`inBounds` day) . amtWhen) $
|
|
dropWhile ((day <) . fst . amtWhen) alloAmts
|
|
where
|
|
go Amount {amtValue, amtDesc} =
|
|
FlatAllocation
|
|
{ faCur = NoX alloCur
|
|
, faTo = alloTo
|
|
, faValue = amtValue
|
|
, faDesc = amtDesc
|
|
}
|
|
|
|
expandTransfers
|
|
:: MonadFinance m
|
|
=> CommitRId
|
|
-> T.Text
|
|
-> [BudgetTransfer]
|
|
-> SqlPersistT m (EitherErrs [UnbalancedTransfer])
|
|
expandTransfers key name ts = do
|
|
txs <- mapM (expandTransfer key name) ts
|
|
return $ L.sortOn cbtWhen . concat <$> concatEithersL txs
|
|
|
|
expandTransfer
|
|
:: MonadFinance m
|
|
=> CommitRId
|
|
-> T.Text
|
|
-> BudgetTransfer
|
|
-> SqlPersistT m (EitherErrs [UnbalancedTransfer])
|
|
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} =
|
|
-- whenHash CTExpense t (Right []) $ \key ->
|
|
fmap (fmap concat . concatEithersL) $
|
|
forM transAmounts $
|
|
\Amount
|
|
{ amtWhen = pat
|
|
, amtValue = BudgetTransferValue {btVal = v, btType = y}
|
|
, amtDesc = desc
|
|
} ->
|
|
do
|
|
withDates pat $ \day ->
|
|
let meta =
|
|
BudgetMeta
|
|
{ bmCommit = key
|
|
, bmName = name
|
|
}
|
|
tx =
|
|
FlatTransfer
|
|
{ cbtMeta = meta
|
|
, cbtWhen = day
|
|
, cbtCur = transCurrency
|
|
, cbtFrom = transFrom
|
|
, cbtTo = transTo
|
|
, cbtValue = UnbalancedValue y $ dec2Rat v
|
|
, cbtDesc = desc
|
|
}
|
|
in return $ Right tx
|
|
|
|
insertBudgetTx :: MonadFinance m => BalancedTransfer -> SqlPersistT m [InsertError]
|
|
insertBudgetTx FlatTransfer {cbtFrom, cbtTo, cbtMeta, cbtCur, cbtValue, cbtDesc, cbtWhen} = do
|
|
res <- lift $ splitPair cbtFrom cbtTo cbtCur cbtValue
|
|
unlessLefts_ res $ \((sFrom, sTo), exchange) -> do
|
|
insertPair sFrom sTo
|
|
forM_ exchange $ uncurry insertPair
|
|
where
|
|
insertPair from to = do
|
|
k <- insert $ TransactionR (bmCommit cbtMeta) cbtWhen cbtDesc
|
|
insertBudgetLabel k from
|
|
insertBudgetLabel k to
|
|
insertBudgetLabel k split = do
|
|
sk <- insertSplit k split
|
|
insert_ $ BudgetLabelR sk $ bmName cbtMeta
|
|
|
|
type SplitPair = (KeySplit, KeySplit)
|
|
|
|
splitPair
|
|
:: MonadFinance m
|
|
=> TaggedAcnt
|
|
-> TaggedAcnt
|
|
-> BudgetCurrency
|
|
-> Rational
|
|
-> m (EitherErrs (SplitPair, Maybe SplitPair))
|
|
splitPair from to cur val = case cur of
|
|
NoX curid -> fmap (,Nothing) <$> pair curid from to val
|
|
X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
|
|
let middle = TaggedAcnt xAcnt []
|
|
res1 <- pair xFromCur from middle val
|
|
res2 <- pair xToCur middle to (val * dec2Rat xRate)
|
|
return $ concatEithers2 res1 res2 $ \a b -> (a, Just b)
|
|
where
|
|
pair curid from_ to_ v = do
|
|
s1 <- split curid from_ (-v)
|
|
s2 <- split curid to_ v
|
|
return $ concatEithers2 s1 s2 (,)
|
|
split c TaggedAcnt {taAcnt, taTags} v =
|
|
resolveSplit $
|
|
Entry
|
|
{ sAcnt = taAcnt
|
|
, sValue = v
|
|
, sComment = ""
|
|
, sCurrency = c
|
|
, sTags = taTags
|
|
}
|
|
|
|
checkAcntType
|
|
:: MonadFinance m
|
|
=> AcntType
|
|
-> AcntID
|
|
-> m (EitherErr AcntID)
|
|
checkAcntType t = checkAcntTypes (t :| [])
|
|
|
|
checkAcntTypes
|
|
:: MonadFinance m
|
|
=> NE.NonEmpty AcntType
|
|
-> AcntID
|
|
-> m (EitherErr AcntID)
|
|
checkAcntTypes ts i = (go =<<) <$> lookupAccountType i
|
|
where
|
|
go t
|
|
| t `L.elem` ts = Right i
|
|
| otherwise = Left $ AccountError i ts
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- statements
|
|
|
|
insertStatements :: MonadFinance m => Config -> SqlPersistT m [InsertError]
|
|
insertStatements conf = concat <$> mapM insertStatement (statements conf)
|
|
|
|
insertStatement :: MonadFinance m => History -> SqlPersistT m [InsertError]
|
|
insertStatement (HistTransfer m) = insertManual m
|
|
insertStatement (HistStatement i) = insertImport i
|
|
|
|
insertManual :: MonadFinance m => HistTransfer -> SqlPersistT m [InsertError]
|
|
insertManual
|
|
m@Transfer
|
|
{ transFrom = from
|
|
, transTo = to
|
|
, transCurrency = u
|
|
, transAmounts = amts
|
|
} = do
|
|
whenHash CTManual m [] $ \c -> do
|
|
bounds <- lift $ askDBState kmStatementInterval
|
|
-- let days = expandDatePat bounds dp
|
|
es <- forM amts $ \Amount {amtWhen, amtValue, amtDesc} -> do
|
|
let v = dec2Rat amtValue
|
|
let dayRes = expandDatePat bounds amtWhen
|
|
unlessLefts dayRes $ \days -> do
|
|
let tx day = txPair day from to u v amtDesc
|
|
txRes <- mapM (lift . tx) days
|
|
unlessLefts_ (concatEithersL txRes) $ mapM_ (insertTx c)
|
|
return $ concat es
|
|
|
|
insertImport :: MonadFinance m => Statement -> SqlPersistT m [InsertError]
|
|
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
|
|
recoverIO (lift $ readImport i) $ \r -> unlessLefts r $ \bs -> do
|
|
bounds <- expandBounds <$> lift (askDBState kmStatementInterval)
|
|
res <- mapM (lift . resolveTx) $ filter (inBounds bounds . txDate) bs
|
|
unlessLefts_ (concatEithersL res) $ mapM_ (insertTx c)
|
|
where
|
|
recoverIO x rest = do
|
|
res <- tryIO x
|
|
case res of
|
|
Right r -> rest r
|
|
-- If file is not found (or something else happens) then collect the
|
|
-- error try the remaining imports
|
|
Left e -> return [InsertIOError $ showT e]
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- low-level transaction stuff
|
|
|
|
-- TODO tags here?
|
|
txPair
|
|
:: MonadFinance m
|
|
=> Day
|
|
-> AcntID
|
|
-> AcntID
|
|
-> CurID
|
|
-> Rational
|
|
-> T.Text
|
|
-> m (EitherErrs KeyTx)
|
|
txPair day from to cur val desc = resolveTx tx
|
|
where
|
|
split a v = Entry {sAcnt = a, sValue = v, sComment = "", sCurrency = cur, sTags = []}
|
|
tx =
|
|
Tx
|
|
{ txDescr = desc
|
|
, txDate = day
|
|
, txSplits = [split from (-val), split to val]
|
|
}
|
|
|
|
resolveTx :: MonadFinance m => BalTx -> m (EitherErrs KeyTx)
|
|
resolveTx t@Tx {txSplits = ss} = do
|
|
res <- concatEithersL <$> mapM resolveSplit ss
|
|
return $ fmap (\kss -> t {txSplits = kss}) res
|
|
|
|
resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit)
|
|
resolveSplit s@Entry {sAcnt, sCurrency, sValue, sTags} = do
|
|
aid <- lookupAccountKey sAcnt
|
|
cid <- lookupCurrency sCurrency
|
|
sign <- lookupAccountSign sAcnt
|
|
tags <- mapM lookupTag sTags
|
|
-- TODO correct sign here?
|
|
-- TODO lenses would be nice here
|
|
return $
|
|
concatEithers2 (concatEither3 aid cid sign (,,)) (concatEitherL tags) $
|
|
\(aid_, cid_, sign_) tags_ ->
|
|
s
|
|
{ sAcnt = aid_
|
|
, sCurrency = cid_
|
|
, sValue = sValue * fromIntegral (sign2Int sign_)
|
|
, sTags = tags_
|
|
}
|
|
|
|
insertTx :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
|
|
insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do
|
|
k <- insert $ TransactionR c d e
|
|
mapM_ (insertSplit k) ss
|
|
|
|
insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m (Key SplitR)
|
|
insertSplit t Entry {sAcnt, sCurrency, sValue, sComment, sTags} = do
|
|
k <- insert $ SplitR t sCurrency sAcnt sComment sValue
|
|
mapM_ (insert_ . TagRelationR k) sTags
|
|
return k
|
|
|
|
lookupAccount :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR, AcntSign, AcntType))
|
|
lookupAccount p = lookupErr (DBKey AcntField) p <$> askDBState kmAccount
|
|
|
|
lookupAccountKey :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR))
|
|
lookupAccountKey = fmap (fmap fstOf3) . lookupAccount
|
|
|
|
lookupAccountSign :: MonadFinance m => AcntID -> m (EitherErr AcntSign)
|
|
lookupAccountSign = fmap (fmap sndOf3) . lookupAccount
|
|
|
|
lookupAccountType :: MonadFinance m => AcntID -> m (EitherErr AcntType)
|
|
lookupAccountType = fmap (fmap thdOf3) . lookupAccount
|
|
|
|
lookupCurrency :: MonadFinance m => T.Text -> m (EitherErr (Key CurrencyR))
|
|
lookupCurrency c = lookupErr (DBKey CurField) c <$> askDBState kmCurrency
|
|
|
|
lookupTag :: MonadFinance m => TagID -> m (EitherErr (Key TagR))
|
|
lookupTag c = lookupErr (DBKey TagField) c <$> askDBState kmTag
|
|
|
|
-- TODO this hashes twice (not that it really matters)
|
|
whenHash
|
|
:: (Hashable a, MonadFinance m)
|
|
=> ConfigType
|
|
-> a
|
|
-> b
|
|
-> (Key CommitR -> SqlPersistT m b)
|
|
-> SqlPersistT m b
|
|
whenHash t o def f = do
|
|
let h = hash o
|
|
hs <- lift $ askDBState kmNewCommits
|
|
if h `elem` hs then f =<< insert (CommitR h t) else return def
|