pwncash/lib/Internal/Insert.hs

366 lines
11 KiB
Haskell
Raw Normal View History

{-# LANGUAGE GADTs #-}
2022-12-11 17:51:11 -05:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
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.Map as M
import qualified RIO.Text as T
import RIO.Time
2023-01-05 22:23:22 -05:00
lookupKey :: (Ord k, Show k, MonadUnliftIO m) => M.Map k v -> k -> m (Maybe v)
2022-12-11 17:51:11 -05:00
lookupKey m k = do
let v = M.lookup k m
when (isNothing v) $
liftIO $
putStrLn $
"key does not exist: " ++ show k
2022-12-11 17:51:11 -05:00
return v
2023-01-05 22:23:22 -05:00
lookupAccount :: MonadUnliftIO m => AcntID -> MappingT m (Maybe (Key AccountR, AcntSign))
2022-12-11 17:51:11 -05:00
lookupAccount p = do
m <- asks kmAccount
lookupKey m p
2023-01-05 22:23:22 -05:00
lookupAccountKey :: MonadUnliftIO m => AcntID -> MappingT m (Maybe (Key AccountR))
2022-12-11 17:51:11 -05:00
lookupAccountKey = fmap (fmap fst) . lookupAccount
2023-01-05 22:23:22 -05:00
lookupAccountSign :: MonadUnliftIO m => AcntID -> MappingT m (Maybe AcntSign)
2022-12-11 17:51:11 -05:00
lookupAccountSign = fmap (fmap snd) . lookupAccount
2023-01-05 22:23:22 -05:00
lookupCurrency :: MonadUnliftIO m => T.Text -> MappingT m (Maybe (Key CurrencyR))
2022-12-11 17:51:11 -05:00
lookupCurrency c = do
m <- asks kmCurrency
lookupKey m c
--------------------------------------------------------------------------------
-- intervals
2023-01-28 19:32:56 -05:00
expandDatePat :: Bounds -> DatePat -> [Day]
expandDatePat (a, b) (Cron cp) = filter (cronPatternMatches cp) [a .. b]
expandDatePat i (Mod mp) = expandModPat mp i
2022-12-11 17:51:11 -05:00
2023-01-28 19:32:56 -05:00
expandModPat :: ModPat -> Bounds -> [Day]
expandModPat
2023-01-25 23:04:54 -05:00
ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r}
2023-01-28 19:32:56 -05:00
(lower, upper) =
takeWhile (<= upper) $
(`addFun` start) . (* b')
<$> maybe id (take . fromIntegral) r [0 ..]
where
2023-01-28 19:32:56 -05:00
start = maybe lower fromGregorian' s
b' = fromIntegral b
addFun = case u of
Day -> addDays
Week -> addDays . (* 7)
Month -> addGregorianMonthsClip
Year -> addGregorianYearsClip
2022-12-11 17:51:11 -05:00
-- TODO this can be optimized to prevent filtering a bunch of dates for
-- one/a few cron patterns
2022-12-11 17:51:11 -05:00
cronPatternMatches :: CronPat -> Day -> Bool
cronPatternMatches
CronPat
{ cronWeekly = w
, cronYear = y
, cronMonth = m
, cronDay = d
}
x =
yMaybe (y' - 2000) y && mdMaybe m' m && mdMaybe d' d && wdMaybe (dayOfWeek_ x) w
where
testMaybe = maybe True
yMaybe z = testMaybe (mdyPatternMatches testYear (fromIntegral z))
mdMaybe z = testMaybe (mdyPatternMatches (const Nothing) (fromIntegral z))
wdMaybe z = testMaybe (`weekdayPatternMatches` z)
(y', m', d') = toGregorian x
testYear z = if z > 99 then Just "year must be 2 digits" else Nothing
2022-12-11 17:51:11 -05:00
2022-12-14 23:59:23 -05:00
dayOfWeek_ :: Day -> Weekday
dayOfWeek_ d = case dayOfWeek d of
Monday -> Mon
Tuesday -> Tue
2022-12-14 23:59:23 -05:00
Wednesday -> Wed
Thursday -> Thu
Friday -> Fri
Saturday -> Sat
Sunday -> Sun
2022-12-14 23:59:23 -05:00
weekdayPatternMatches :: WeekdayPat -> Weekday -> Bool
weekdayPatternMatches (OnDay x) = (== x)
2022-12-11 17:51:11 -05:00
weekdayPatternMatches (OnDays xs) = (`elem` xs)
mdyPatternMatches :: (Natural -> Maybe String) -> Natural -> MDYPat -> Bool
mdyPatternMatches check x p = case p of
Single y -> errMaybe (check y) $ x == y
Multi xs -> errMaybe (msum $ check <$> xs) $ x `elem` xs
Repeat (RepeatPat {rpStart = s, rpBy = b, rpRepeats = r}) ->
errMaybe (check s) $
s >= x && mod x b == 0 && maybe True (\y -> x <= s + b * y) r
where
errMaybe test rest = maybe rest err test
err msg = error $ show p ++ ": " ++ msg
2022-12-11 17:51:11 -05:00
--------------------------------------------------------------------------------
-- budget
2023-01-25 23:04:54 -05:00
insertBudget :: MonadUnliftIO m => Budget -> MappingT m [InsertError]
insertBudget Budget {income = is, expenses = es} = do
2023-01-28 19:32:56 -05:00
mapM_ insertExpense es
concat <$> mapM insertIncome is
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
2023-01-27 20:31:13 -05:00
insertIncome :: MonadUnliftIO m => Income -> MappingT m [InsertError]
insertIncome
i@Income
{ incCurrency = cur
, incWhen = dp
, incAccount = from
, incTaxes = ts
} =
2023-01-27 20:31:13 -05:00
whenHash CTIncome i [] $ \c -> do
bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
2023-01-28 19:32:56 -05:00
unlessLeft (balanceIncome i) $ \balanced -> do
forM_ (expandDatePat bounds dp) $ \day -> do
alloTx <- concat <$> mapM (allocationToTx from day) balanced
taxTx <- fmap (,Fixed) <$> mapM (taxToTx from day cur) ts
lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) $ alloTx ++ taxTx
2023-01-27 20:31:13 -05:00
balanceIncome :: Income -> EitherErr [BalAllocation]
balanceIncome
Income
{ incGross = g
2023-01-28 19:32:56 -05:00
, incWhen = dp
, incPretax = pre
, incTaxes = tax
, incPosttax = post
2023-01-28 19:32:56 -05:00
} = (preRat ++) <$> balancePostTax dp bal postRat
where
preRat = mapAlloAmts dec2Rat <$> pre
postRat = mapAlloAmts (fmap dec2Rat) <$> post
bal = dec2Rat g - (sumAllocations preRat + sumTaxes tax)
2022-12-11 17:51:11 -05:00
mapAlloAmts :: (a -> b) -> Allocation a -> Allocation b
mapAlloAmts f a@Allocation {alloAmts = as} = a {alloAmts = fmap f <$> as}
2022-12-11 17:51:11 -05:00
sumAllocations :: [BalAllocation] -> Rational
sumAllocations = sum . concatMap (fmap amtValue . alloAmts)
sumTaxes :: [Tax] -> Rational
sumTaxes = sum . fmap (dec2Rat . taxValue)
balancePostTax :: DatePat -> Rational -> [RawAllocation] -> EitherErr [BalAllocation]
balancePostTax dp bal as
| null as = err NoAllocations
2022-12-11 17:51:11 -05:00
| otherwise = case partitionEithers $ fmap hasVal as of
([([empty], nonmissing)], bs) ->
let s = bal - sumAllocations (nonmissing : bs)
in if s < 0
then err ExceededTotal
else Right $ mapAmts (empty {amtValue = s} :) nonmissing : bs
([], _) -> err MissingBlank
_ -> err TooManyBlanks
2022-12-11 17:51:11 -05:00
where
hasVal a@Allocation {alloAmts = xs} =
2022-12-11 17:51:11 -05:00
case partitionEithers $ fmap maybeAmt xs of
([], bs) -> Right a {alloAmts = bs}
(unbal, bs) -> Left (unbal, a {alloAmts = bs})
maybeAmt a@Amount {amtValue = Just v} = Right a {amtValue = v}
maybeAmt a = Left a
err t = Left $ AllocationError t dp
2022-12-11 17:51:11 -05:00
-- TODO lens reinvention
mapAmts :: ([Amount a] -> [Amount b]) -> Allocation a -> Allocation b
mapAmts f a@Allocation {alloAmts = xs} = a {alloAmts = f xs}
2022-12-11 17:51:11 -05:00
allocationToTx
2023-01-05 22:23:22 -05:00
:: MonadUnliftIO m
=> AcntID
-> Day
-> BalAllocation
2022-12-11 17:51:11 -05:00
-> MappingT m [(KeyTx, Bucket)]
allocationToTx
from
day
Allocation
{ alloPath = to
, alloBucket = b
, alloCurrency = cur
, alloAmts = as
} =
fmap (,b) <$> mapM (transferToTx day from to cur) as
2022-12-11 17:51:11 -05:00
2023-01-05 22:23:22 -05:00
taxToTx :: MonadUnliftIO m => AcntID -> Day -> T.Text -> Tax -> MappingT m KeyTx
taxToTx from day cur Tax {taxAcnt = to, taxValue = v} =
2022-12-11 17:51:11 -05:00
txPair day from to cur (dec2Rat v) ""
transferToTx
2023-01-05 22:23:22 -05:00
:: MonadUnliftIO m
=> Day
-> AcntID
-> AcntID
-> T.Text
-> BalAmount
2022-12-11 17:51:11 -05:00
-> MappingT m KeyTx
transferToTx day from to cur Amount {amtValue = v, amtDesc = d} =
2022-12-11 17:51:11 -05:00
txPair day from to cur v d
2023-01-28 19:32:56 -05:00
insertExpense :: MonadUnliftIO m => Expense -> MappingT m ()
insertExpense
e@Expense
{ expFrom = from
, expTo = to
, expCurrency = cur
, expBucket = buc
, expAmounts = as
} = do
2023-01-28 19:32:56 -05:00
whenHash CTExpense e () $ \key -> mapM_ (go key) as
2023-01-25 23:04:54 -05:00
where
go key amt = do
2023-01-28 19:32:56 -05:00
keys <- timeAmountToTx from to cur amt
lift $ mapM_ (insertTxBucket (Just buc) key) keys
timeAmountToTx
2023-01-05 22:23:22 -05:00
:: MonadUnliftIO m
=> AcntID
-> AcntID
2023-01-25 23:04:54 -05:00
-> CurID
-> TimeAmount
2023-01-28 19:32:56 -05:00
-> MappingT m [KeyTx]
timeAmountToTx
from
to
cur
TimeAmount
{ taWhen = dp
, taAmt =
Amount
{ amtValue = v
, amtDesc = d
}
} = do
bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
2023-01-28 19:32:56 -05:00
mapM tx $ expandDatePat bounds dp
where
tx day = txPair day from to cur (dec2Rat v) d
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
-- unless (null es) $ throwIO $ InsertException es
2022-12-11 17:51:11 -05:00
2023-01-27 20:31:13 -05:00
insertStatement :: MonadUnliftIO m => Statement -> MappingT m [InsertError]
2023-01-28 19:32:56 -05:00
insertStatement (StmtManual m) = insertManual m >> return []
2022-12-11 17:51:11 -05:00
insertStatement (StmtImport i) = insertImport i
2023-01-28 19:32:56 -05:00
insertManual :: MonadUnliftIO m => Manual -> MappingT m ()
insertManual
m@Manual
{ manualDate = dp
, manualFrom = from
, manualTo = to
, manualValue = v
, manualCurrency = u
, manualDesc = e
} = do
2023-01-28 19:32:56 -05:00
whenHash CTManual m () $ \c -> do
bounds <- (liftIO . resolveBounds) =<< asks kmStatementInterval
2023-01-28 19:32:56 -05:00
ts <- mapM tx $ expandDatePat bounds dp
lift $ mapM_ (insertTx c) ts
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
bounds <- asks kmStatementInterval
2023-01-24 22:15:32 -05:00
res <- readImport i
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-27 20:31:13 -05:00
unlessLefts res $ \bs -> do
rs <- mapM resolveTx $ filter (inMaybeBounds bounds . txDate) bs
lift $ mapM_ (insertTx c) rs
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
-> T.Text
-> Rational
-> T.Text
2022-12-11 17:51:11 -05:00
-> MappingT m KeyTx
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-05 22:23:22 -05:00
resolveTx :: MonadUnliftIO m => BalTx -> MappingT m KeyTx
resolveTx t@Tx {txSplits = ss} = do
2022-12-11 17:51:11 -05:00
rs <- catMaybes <$> mapM resolveSplit ss
return $ t {txSplits = rs}
2022-12-11 17:51:11 -05:00
2023-01-05 22:23:22 -05:00
resolveSplit :: MonadUnliftIO m => BalSplit -> MappingT m (Maybe 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
return $ case (aid, cid, sign) of
(Just aid', Just cid', Just sign') ->
Just $
s
{ sAcnt = aid'
, sCurrency = cid'
, sValue = v * fromIntegral (sign2Int sign')
}
2022-12-11 17:51:11 -05:00
_ -> Nothing
2023-01-05 22:23:22 -05:00
insertTxBucket :: MonadUnliftIO m => Maybe Bucket -> Key CommitR -> KeyTx -> SqlPersistT m ()
insertTxBucket b c Tx {txDate = d, txDescr = e, txSplits = ss} = do
2022-12-11 17:51:11 -05:00
k <- insert $ TransactionR c d e (fmap (T.pack . show) b)
mapM_ (insertSplit k) ss
2023-01-05 22:23:22 -05:00
insertTx :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
2022-12-11 17:51:11 -05:00
insertTx = insertTxBucket Nothing
2023-01-05 22:23:22 -05:00
insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m ()
insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do
2022-12-11 17:51:11 -05:00
insert_ $ SplitR t cid aid c v