pwncash/lib/Internal/Insert.hs

373 lines
12 KiB
Haskell
Raw Normal View History

{-# LANGUAGE GADTs #-}
2022-12-11 17:51:11 -05:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
2023-01-28 22:55:07 -05:00
{-# LANGUAGE NoImplicitPrelude #-}
2022-12-11 17:51:11 -05:00
module Internal.Insert
( insertStatements
, insertBudget
)
where
import Data.Hashable
import Database.Persist.Class
import Database.Persist.Sql hiding (Single, Statement)
import Internal.Database.Model
import Internal.Statement
import Internal.Types hiding (sign)
import Internal.Utils
import RIO hiding (to)
import qualified RIO.Text as T
import RIO.Time
2022-12-11 17:51:11 -05:00
--------------------------------------------------------------------------------
-- intervals
expandDatePat :: Bounds -> DatePat -> EitherErrs [Day]
2023-02-02 23:18:36 -05:00
expandDatePat b (Cron cp) = expandCronPat b cp
expandDatePat i (Mod mp) = Right $ 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
expandCronPat :: Bounds -> CronPat -> EitherErrs [Day]
expandCronPat b CronPat {..} = 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]
2023-01-30 21:47:17 -05:00
where
yRes = case cronYear of
Nothing -> return [yb0 .. yb1]
Just pat -> do
ys <- expandMDYPat (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 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 -> MDYPat -> EitherErr [Natural]
expandMDYPat _ (Single x) = Right [x]
expandMDYPat _ (Multi xs) = Right xs
expandMDYPat lim (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r})
| b < 1 = Left $ PatternError s b r ZeroLength
| otherwise = do
k <- limit r
return $ takeWhile (<= k) [s + i * b | i <- [0 ..]]
where
limit Nothing = Right lim
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)) lim
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
:: MonadUnliftIO m
=> DatePat
-> (Day -> MappingT m a)
-> MappingT m (EitherErrs [a])
2023-01-30 21:47:17 -05:00
withDates dp f = do
bounds <- asks kmBudgetInterval
let days = expandDatePat bounds dp
mapM (mapM f) days
2023-01-30 21:47:17 -05:00
2022-12-11 17:51:11 -05:00
--------------------------------------------------------------------------------
-- budget
2023-01-25 23:04:54 -05:00
insertBudget :: MonadUnliftIO m => Budget -> MappingT m [InsertError]
2023-01-30 22:48:16 -05:00
insertBudget Budget {income = is, transfers = es} = do
2023-01-28 22:55:07 -05:00
es1 <- mapM insertIncome is
2023-01-30 21:12:08 -05:00
es2 <- mapM insertTransfer es
2023-01-28 22:55:07 -05:00
return $ concat $ es1 ++ es2
2022-12-11 17:51:11 -05:00
-- TODO this hashes twice (not that it really matters)
whenHash
2023-01-24 23:24:41 -05:00
:: (Hashable a, MonadUnliftIO m)
=> ConfigType
-> a
2023-01-24 23:24:41 -05:00
-> b
-> (Key CommitR -> MappingT m b)
-> MappingT m b
whenHash t o def f = do
2022-12-11 17:51:11 -05:00
let h = hash o
hs <- asks kmNewCommits
2023-01-24 23:24:41 -05:00
if h `elem` hs then f =<< lift (insert $ CommitR h t) else return def
2022-12-11 17:51:11 -05:00
-- TODO allow currency conversions here
data BudgetSplit b = BudgetSplit
2023-01-30 22:57:42 -05:00
{ bsAcnt :: !AcntID
, bsBucket :: !(Maybe b)
}
data BudgetMeta = BudgetMeta
2023-01-30 22:57:42 -05:00
{ bmCommit :: !(Key CommitR)
, bmWhen :: !Day
, bmCur :: !CurID
}
data BudgetTx = BudgetTx
2023-01-30 22:57:42 -05:00
{ btMeta :: !BudgetMeta
, btFrom :: !(BudgetSplit IncomeBucket)
, btTo :: !(BudgetSplit ExpenseBucket)
, btValue :: !Rational
, btDesc :: !T.Text
}
2023-01-27 20:31:13 -05:00
insertIncome :: MonadUnliftIO m => Income -> MappingT m [InsertError]
insertIncome i@Income {..} =
whenHash CTIncome i [] $ \c ->
unlessLeft (balanceIncome i) $ \balance -> do
res <- withDates incWhen $ \day -> do
let meta = BudgetMeta c day incCurrency
let fromAllos b = concatMap (fromAllo meta incFrom (Just b))
let pre = fromAllos PreTax incPretax
let tax = fmap (fromTax meta incFrom) incTaxes
let post = fromAllos PostTax incPosttax
let bal =
BudgetTx
{ btMeta = meta
, btFrom = BudgetSplit incFrom $ Just PostTax
, btTo = BudgetSplit incToBal Nothing
, btValue = balance
, btDesc = "balance after deductions"
}
fmap concat $ mapM insertBudgetTx $ bal : (pre ++ tax ++ post)
unlessLefts res $ return . concat
fromAllo
:: BudgetMeta
-> AcntID
-> Maybe IncomeBucket
-> Allocation
-> [BudgetTx]
fromAllo meta from ib Allocation {..} = fmap (toBT alloPath) alloAmts
where
toBT to (Amount desc v) =
BudgetTx
{ btFrom = BudgetSplit from ib
, btTo = BudgetSplit to $ Just alloBucket
, btValue = dec2Rat v
, btDesc = desc
, btMeta = meta
}
2023-01-27 20:31:13 -05:00
fromTax :: BudgetMeta -> AcntID -> Tax -> BudgetTx
fromTax meta from Tax {taxAcnt = to, taxValue = v} =
BudgetTx
{ btFrom = BudgetSplit from (Just IntraTax)
, btTo = BudgetSplit to (Just Fixed)
, btValue = dec2Rat v
, btDesc = ""
, btMeta = meta
}
balanceIncome :: Income -> EitherErr Rational
balanceIncome
Income
{ incGross = g
2023-01-28 19:32:56 -05:00
, incWhen = dp
, incPretax = pre
, incTaxes = tax
, incPosttax = post
}
2023-01-30 21:12:08 -05:00
| bal < 0 = Left $ IncomeError dp
| otherwise = Right bal
where
bal = dec2Rat g - sum (sumAllocation <$> pre ++ post) - sumTaxes tax
2022-12-11 17:51:11 -05:00
sumAllocation :: Allocation -> Rational
sumAllocation = sum . fmap (dec2Rat . amtValue) . alloAmts
2022-12-11 17:51:11 -05:00
sumTaxes :: [Tax] -> Rational
sumTaxes = sum . fmap (dec2Rat . taxValue)
2023-01-30 21:12:08 -05:00
insertTransfer :: MonadUnliftIO m => Transfer -> MappingT m [InsertError]
insertTransfer t@Transfer {..} =
fmap concat $ whenHash CTExpense t [] $ \key -> do
forM transAmounts $ \(TimeAmount amt pat) -> do
res <- withDates pat $ \day -> insertBudgetTx $ budgetTx amt day key
unlessLefts res $ return . concat
where
2023-01-30 21:12:08 -05:00
meta d c = BudgetMeta {bmWhen = d, bmCur = transCurrency, bmCommit = c}
budgetTx (Amount desc v) d c =
BudgetTx
{ btMeta = meta d c
2023-01-30 21:12:08 -05:00
, btFrom = BudgetSplit transFrom Nothing
, btTo = BudgetSplit transTo Nothing
, btValue = dec2Rat v
, btDesc = desc
}
2022-12-11 17:51:11 -05:00
2023-01-30 21:47:17 -05:00
insertBudgetTx :: MonadUnliftIO m => BudgetTx -> MappingT m [InsertError]
insertBudgetTx BudgetTx {..} = do
res <- splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue
unlessLefts_ res $ \(sFrom, sTo) -> lift $ do
k <- insert $ TransactionR (bmCommit btMeta) (bmWhen btMeta) btDesc
skFrom <- insertSplit k sFrom
bFrom <- insert $ BudgetLabelR skFrom ""
forM_ (bsBucket btFrom) $ \b ->
insert_ $ IncomeBucketR bFrom b
skTo <- insertSplit k sTo
bTo <- insert $ BudgetLabelR skTo ""
forM_ (bsBucket btTo) $ \b ->
insert_ $ ExpenseBucketR bTo b
splitPair
:: MonadUnliftIO m
=> AcntID
-> AcntID
-> CurID
-> Rational
-> MappingT m (EitherErrs (KeySplit, KeySplit))
splitPair from to cur val = do
s1 <- split from (-val)
s2 <- split to val
return $ concatEithers2 s1 s2 (,)
where
split a v =
resolveSplit $
Split
{ sAcnt = a
, sValue = v
, sComment = ""
, sCurrency = cur
}
2022-12-11 17:51:11 -05:00
--------------------------------------------------------------------------------
-- statements
2023-01-25 23:04:54 -05:00
insertStatements :: MonadUnliftIO m => Config -> MappingT m [InsertError]
2023-01-27 20:31:13 -05:00
insertStatements conf = concat <$> mapM insertStatement (statements conf)
2023-01-25 23:04:54 -05:00
2023-01-27 20:31:13 -05:00
insertStatement :: MonadUnliftIO m => Statement -> MappingT m [InsertError]
2023-01-28 22:55:07 -05:00
insertStatement (StmtManual m) = insertManual m
2022-12-11 17:51:11 -05:00
insertStatement (StmtImport i) = insertImport i
2023-01-28 22:55:07 -05:00
insertManual :: MonadUnliftIO m => Manual -> MappingT m [InsertError]
insertManual
m@Manual
{ manualDate = dp
, manualFrom = from
, manualTo = to
, manualValue = v
, manualCurrency = u
, manualDesc = e
} = do
2023-01-28 22:55:07 -05:00
whenHash CTManual m [] $ \c -> do
bounds <- asks kmStatementInterval
-- let days = expandDatePat bounds dp
let dayRes = expandDatePat bounds dp
unlessLefts dayRes $ \days -> do
txRes <- mapM tx days
unlessLefts_ (concatEithersL txRes) $ lift . mapM_ (insertTx c)
where
tx day = txPair day from to u (dec2Rat v) e
2022-12-11 17:51:11 -05:00
2023-01-27 20:31:13 -05:00
insertImport :: MonadUnliftIO m => Import -> MappingT m [InsertError]
insertImport i = whenHash CTImport i [] $ \c -> do
2022-12-11 17:51:11 -05:00
-- TODO this isn't efficient, the whole file will be read and maybe no
-- transactions will be desired
2023-01-28 22:55:07 -05:00
recoverIO (readImport i) $ \r -> unlessLefts r $ \bs -> do
bounds <- expandBounds <$> asks kmStatementInterval
res <- mapM resolveTx $ filter (inBounds bounds . txDate) bs
2023-01-28 22:55:07 -05:00
unlessLefts_ (concatEithersL res) $ lift . 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]
2022-12-11 17:51:11 -05:00
--------------------------------------------------------------------------------
-- low-level transaction stuff
txPair
2023-01-05 22:23:22 -05:00
:: MonadUnliftIO m
=> Day
-> AcntID
-> AcntID
-> CurID
-> Rational
-> T.Text
2023-01-28 22:55:07 -05:00
-> MappingT m (EitherErrs KeyTx)
2022-12-11 17:51:11 -05:00
txPair day from to cur val desc = resolveTx tx
where
split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur}
tx =
Tx
{ txDescr = desc
, txDate = day
, txTags = []
, txSplits = [split from (-val), split to val]
}
2022-12-11 17:51:11 -05:00
2023-01-28 22:55:07 -05:00
resolveTx :: MonadUnliftIO m => BalTx -> MappingT m (EitherErrs KeyTx)
resolveTx t@Tx {txSplits = ss} = do
2023-01-28 22:55:07 -05:00
res <- concatEithersL <$> mapM resolveSplit ss
return $ fmap (\kss -> t {txSplits = kss}) res
2022-12-11 17:51:11 -05:00
2023-01-28 22:55:07 -05:00
resolveSplit :: MonadUnliftIO m => BalSplit -> MappingT m (EitherErrs KeySplit)
resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do
2022-12-11 17:51:11 -05:00
aid <- lookupAccountKey p
cid <- lookupCurrency c
sign <- lookupAccountSign p
-- TODO correct sign here?
-- TODO lenses would be nice here
2023-01-28 22:55:07 -05:00
return $ concatEither3 aid cid sign $ \aid_ cid_ sign_ ->
s
{ sAcnt = aid_
, sCurrency = cid_
, sValue = v * fromIntegral (sign2Int sign_)
}
2023-01-30 21:47:17 -05:00
insertTx :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
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
insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m (Key SplitR)
insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do
insert $ SplitR t cid aid c v
2023-01-28 22:55:07 -05:00
lookupAccount :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr (Key AccountR, AcntSign))
lookupAccount p = lookupErr (DBKey AcntField) p <$> asks kmAccount
lookupAccountKey :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr (Key AccountR))
lookupAccountKey = fmap (fmap fst) . lookupAccount
lookupAccountSign :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr AcntSign)
lookupAccountSign = fmap (fmap snd) . lookupAccount
lookupCurrency :: MonadUnliftIO m => T.Text -> MappingT m (EitherErr (Key CurrencyR))
lookupCurrency c = lookupErr (DBKey CurField) c <$> asks kmCurrency