diff --git a/app/Main.hs b/app/Main.hs index 597a8c1..336fdda 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -174,19 +174,25 @@ runSync c = do liftIOExceptT $ getDBState config -- read desired statements from disk - bSs <- - flip runReaderT state $ - catMaybes <$> mapErrorsIO (readHistStmt root) hSs + (rus, is) <- + flip runReaderT state $ do + hSs' <- mapErrorsIO (readHistStmt root) hSs + hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs + bTs <- liftIOExceptT $ mapErrors readBudget $ budget config + return $ second concat $ partitionEithers $ hSs' ++ hTs' ++ bTs -- update the DB runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do - let runHist = do - ts <- catMaybes <$> mapErrors readHistTransfer hTs - insertHistory $ bSs ++ ts - let runBudget = mapErrors insertBudget $ budget config + res <- runExceptT $ do + -- TODO taking out the hash is dumb + (rs, ues) <- readUpdates $ fmap commitRHash rus + let ebs = fmap ToUpdate ues ++ fmap ToRead rs ++ fmap ToInsert is + 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 updateDBState updates -- TODO this will only work if foreign keys are deferred - res <- runExceptT $ combineError runHist runBudget $ \_ _ -> () - rerunnableIO $ fromEither res -- TODO why is this here? where root = takeDirectory c err (InsertException es) = do diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs index f95dea6..7cd60b4 100644 --- a/lib/Internal/Budget.hs +++ b/lib/Internal/Budget.hs @@ -1,10 +1,8 @@ -module Internal.Budget (insertBudget) where +module Internal.Budget (readBudget) where import Control.Monad.Except import Data.Foldable -import Database.Persist.Monad import Internal.Database -import Internal.History import Internal.Types.Main import Internal.Utils import RIO hiding (to) @@ -25,11 +23,11 @@ import RIO.Time -- 4. assign shadow transactions -- 5. insert all transactions -insertBudget - :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) +readBudget + :: (MonadInsertError m, MonadFinance m) => Budget - -> m () -insertBudget + -> m (Either CommitR [Tx TxCommit]) +readBudget b@Budget { bgtLabel , bgtIncomes @@ -40,14 +38,13 @@ insertBudget , bgtPosttax , bgtInterval } = - whenHash CTBudget b () $ \key -> do + eitherHash CTBudget b return $ \key -> do (intAllos, _) <- combineError intAlloRes acntRes (,) - let res1 = mapErrors (insertIncome key bgtLabel intAllos bgtInterval) bgtIncomes + let res1 = mapErrors (readIncome key bgtLabel intAllos bgtInterval) bgtIncomes let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers txs <- combineError (concat <$> res1) res2 (++) shadow <- addShadowTransfers bgtShadowTransfers txs - (_, toIns) <- balanceTxs $ fmap ToInsert $ txs ++ shadow - void $ insertBudgetTx toIns + return $ txs ++ shadow where acntRes = mapErrors isNotIncomeAcnt alloAcnts intAlloRes = combineError3 pre_ tax_ post_ (,,) @@ -60,60 +57,6 @@ insertBudget ++ (alloAcnt <$> bgtTax) ++ (alloAcnt <$> bgtPosttax) --- TODO need to systematically make this function match the history version, --- which will allow me to use the same balancing algorithm for both --- balanceTransfers :: [Tx BudgetMeta] -> [KeyEntry] --- balanceTransfers = undefined - --- balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen --- where --- go bals f@FlatTransfer {ftFrom, ftTo, ftValue = UnbalancedValue {cvValue, cvType}} = --- let balTo = M.findWithDefault 0 ftTo bals --- x = amtToMove balTo cvType cvValue --- bals' = mapAdd_ ftTo x $ mapAdd_ ftFrom (-x) bals --- in (bals', f {ftValue = 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 _ TFixed x = x --- amtToMove bal TPercent x = -(x / 100 * bal) --- amtToMove bal TBalance x = x - bal - -insertBudgetTx - :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) - => [InsertTx BudgetMeta] - -> m () -insertBudgetTx toInsert = do - forM_ (groupKey (commitRHash . bmCommit) $ (\x -> (itxCommit x, x)) <$> toInsert) $ - \(c, ts) -> do - ck <- insert $ bmCommit c - mapM_ (insertTx ck) ts - where - insertTx c InsertTx {itxDate = d, itxDescr = e, itxEntries = ss, itxCommit = BudgetMeta {bmName}} = do - let anyDeferred = any (isJust . feDeferred) ss - k <- insert $ TransactionR c d e anyDeferred - mapM_ (insertBudgetLabel bmName k) ss - insertBudgetLabel n k entry = do - sk <- insertEntry k entry - insert_ $ BudgetLabelR sk n - --- insertBudgetTx --- :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) --- => BalancedTransfer --- -> m () --- insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do --- ((sFrom, sTo), exchange) <- entryPair ftFrom ftTo ftCur ftValue --- insertPair sFrom sTo --- forM_ exchange $ uncurry insertPair --- where --- insertPair from to = do --- k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc --- insertBudgetLabel k from --- insertBudgetLabel k to --- insertBudgetLabel k entry = do --- sk <- insertEntry k entry --- insert_ $ BudgetLabelR sk $ bmName ftMeta - entryPair :: (MonadInsertError m, MonadFinance m) => TaggedAcnt @@ -170,15 +113,15 @@ sortAllo a@Allocation {alloAmts = as} = do -- 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 :( -insertIncome +readIncome :: (MonadInsertError m, MonadFinance m) - => CommitRId + => CommitR -> T.Text -> IntAllocations -> Maybe Interval -> Income - -> m [Tx BudgetMeta] -insertIncome + -> m [Tx TxCommit] +readIncome key name (intPre, intTax, intPost) @@ -212,7 +155,7 @@ insertIncome dayRes = askDays incWhen localInterval start = fromGregorian' $ pStart incPayPeriod pType' = pType incPayPeriod - meta = BudgetMeta key name + meta = BudgetCommit key name flatPre = concatMap flattenAllo incPretax flatTax = concatMap flattenAllo incTaxes flatPost = concatMap flattenAllo incPosttax @@ -352,11 +295,11 @@ selectAllos day Allocation {alloAmts, alloCur, alloTo} = allo2Trans :: (MonadInsertError m, MonadFinance m) - => BudgetMeta + => TxCommit -> Day -> TaggedAcnt -> FlatAllocation Rational - -> m (Tx BudgetMeta) + -> m (Tx TxCommit) allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = do -- TODO double here? p <- entryPair from faTo faCur faDesc (fromRational faValue) @@ -441,12 +384,12 @@ allocatePost precision aftertax = fmap (fmap go) -- Standalone Transfer expandTransfers - :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) - => CommitRId + :: (MonadInsertError m, MonadFinance m) + => CommitR -> T.Text -> Maybe Interval -> [BudgetTransfer] - -> m [Tx BudgetMeta] + -> m [Tx TxCommit] expandTransfers key name localInterval ts = do txs <- fmap (L.sortOn txDate . concat) $ @@ -459,13 +402,13 @@ expandTransfers key name localInterval ts = do return $ filter (inDaySpan bounds . txDate) txs expandTransfer - :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) - => CommitRId + :: (MonadInsertError m, MonadFinance m) + => CommitR -> T.Text -> BudgetTransfer - -> m [Tx BudgetMeta] -expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do - fmap concat $ mapErrors go transAmounts + -> m [Tx TxCommit] +expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = + concat <$> mapErrors go transAmounts where go Amount @@ -474,7 +417,7 @@ expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFro , amtDesc = desc } = withDates pat $ \day -> do - let meta = BudgetMeta {bmCommit = key, bmName = name} + let meta = BudgetCommit key name p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v return Tx @@ -486,7 +429,7 @@ expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFro } withDates - :: (MonadSqlQuery m, MonadFinance m, MonadInsertError m) + :: (MonadFinance m, MonadInsertError m) => DatePat -> (Day -> m a) -> m [a] @@ -502,9 +445,9 @@ withDates dp f = do addShadowTransfers :: (MonadInsertError m, MonadFinance m) => [ShadowTransfer] - -> [Tx BudgetMeta] - -> m [Tx BudgetMeta] -addShadowTransfers ms txs = mapErrors go txs + -> [Tx TxCommit] + -> m [Tx TxCommit] +addShadowTransfers ms = mapErrors go where go tx = do es <- catMaybes <$> mapErrors (fromShadow tx) ms @@ -512,7 +455,7 @@ addShadowTransfers ms txs = mapErrors go txs fromShadow :: (MonadInsertError m, MonadFinance m) - => Tx BudgetMeta + => Tx TxCommit -> ShadowTransfer -> m (Maybe (EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational)))) fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = do @@ -520,7 +463,7 @@ fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch es <- entryPair_ (\_ v -> Left v) stFrom stTo stCurrency stDesc stRatio return $ if not res then Nothing else Just es -shadowMatches :: TransferMatcher -> Tx BudgetMeta -> InsertExcept Bool +shadowMatches :: TransferMatcher -> Tx TxCommit -> InsertExcept Bool shadowMatches TransferMatcher {tmFrom, tmTo, tmDate} 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 @@ -538,10 +481,6 @@ shadowMatches TransferMatcher {tmFrom, tmTo, tmDate} Tx {txPrimary, txDate} = do -------------------------------------------------------------------------------- -- random --- initialCurrency :: TransferCurrency -> CurID --- initialCurrency (NoX c) = c --- initialCurrency (X Exchange {xFromCur = c}) = c - alloAcnt :: Allocation w v -> AcntID alloAcnt = taAcnt . alloTo @@ -551,85 +490,6 @@ data UnbalancedValue = UnbalancedValue } deriving (Show) --- TODO need to make this into the same ish thing as the Tx/EntrySet structs --- in the history algorithm, which will entail resolving the budget currency --- stuff earlier in the chain, and preloading multiple entries into this thing --- before balancing. --- type UnbalancedTransfer = FlatTransfer UnbalancedValue - --- ubt2tx :: UnbalancedTransfer -> Tx BudgetMeta --- ubt2tx --- FlatTransfer --- { ftFrom --- , ftTo --- , ftValue --- , ftWhen --- , ftDesc --- , ftMeta --- , ftCur --- } = --- Tx --- { txDescr = ftDesc --- , txDate = ftWhen --- , txPrimary = p --- , txOther = maybeToList os --- , txCommit = ftMeta --- } --- where --- (p, os) = entries ftCur --- entries (NoX curid) = (pair curid ftFrom ftTo ftValue, Nothing) --- entries (X Exchange {xFromCur, xToCur, xAcnt, xRate}) = --- let middle = TaggedAcnt xAcnt [] --- p1 = pair xFromCur ftFrom middle ftValue --- p2 = pair xToCur middle ftTo (ftValue * roundPrecision 3 xRate) --- in (p1, Just p2) --- pair c (TaggedAcnt fa fts) (TaggedAcnt ta tts) v = --- EntrySet --- { esTotalValue = v --- , esCurrency = c --- , esFrom = --- HalfEntrySet --- { hesPrimary = --- Entry --- { eValue = () --- , eComment = "" --- , eAcnt = fa --- , eTags = fts --- } --- , hesOther = [] --- } --- , esTo = --- HalfEntrySet --- { hesPrimary = --- Entry --- { eValue = () --- , eComment = "" --- , eAcnt = ta --- , eTags = tts --- } --- , hesOther = [] --- } --- } - --- type BalancedTransfer = FlatTransfer Rational - --- data FlatTransfer v = FlatTransfer --- { ftFrom :: !TaggedAcnt --- , ftTo :: !TaggedAcnt --- , ftValue :: !v --- , ftWhen :: !Day --- , ftDesc :: !T.Text --- , ftMeta :: !BudgetMeta --- , ftCur :: !TransferCurrency --- } --- deriving (Show) - -data BudgetMeta = BudgetMeta - { bmCommit :: !CommitR - , bmName :: !T.Text - } - deriving (Show) - type IntAllocations = ( [DaySpanAllocation PretaxValue] , [DaySpanAllocation TaxValue] @@ -638,8 +498,6 @@ type IntAllocations = type DaySpanAllocation = Allocation DaySpan -type EntryPair = (KeyEntry, KeyEntry) - type PeriodScaler = Natural -> Double -> Double data FlatAllocation v = FlatAllocation diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs index 2598c59..12fd398 100644 --- a/lib/Internal/Database.hs +++ b/lib/Internal/Database.hs @@ -459,7 +459,7 @@ resolveEntry s@InsertEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency readUpdates :: (MonadInsertError m, MonadSqlQuery m) => [Int] - -> m [Either ReadEntry UpdateEntrySet] + -> m ([ReadEntry], [UpdateEntrySet]) readUpdates hashes = do xs <- selectE $ do (commits :& txs :& entries) <- @@ -482,7 +482,7 @@ readUpdates hashes = do liftExcept $ mapErrors makeUES $ second (fmap snd) <$> groupWith uGroup toUpdate - return $ fmap Left toRead ++ fmap Right toUpdate' + return (toRead, toUpdate') where unpack = fmap (\(_, d, e) -> (E.unValue d, (entityKey e, entityVal e))) uGroup (day, (_, e)) = (day, entryRCurrency e, entryRTransaction e) diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index f5d67d6..b7da1f3 100644 --- a/lib/Internal/History.hs +++ b/lib/Internal/History.hs @@ -1,9 +1,10 @@ module Internal.History ( readHistStmt , readHistTransfer - , insertHistory + , insertAll , splitHistory , balanceTxs + , updateTx ) where @@ -26,21 +27,11 @@ import qualified RIO.Text as T import RIO.Time import qualified RIO.Vector as V --- readHistory --- :: (MonadInsertError m, MonadFinance m, MonadUnliftIO m) --- => FilePath --- -> [History] --- -> m [(CommitR, [DeferredTx])] --- readHistory root hs = do --- let (ts, ss) = splitHistory hs --- ts' <- catMaybes <$> mapErrorsIO readHistTransfer ts --- ss' <- catMaybes <$> mapErrorsIO (readHistStmt root) ss --- return $ ts' ++ ss' - +-- TODO unify this with the transfer system I use in the budget now readHistTransfer :: (MonadInsertError m, MonadFinance m) => HistTransfer - -> m [Tx CommitR] + -> m (Either CommitR [Tx TxCommit]) readHistTransfer m@Transfer { transFrom = from @@ -48,7 +39,7 @@ readHistTransfer , transCurrency = u , transAmounts = amts } = - whenHash0 CTManual m [] $ \c -> do + eitherHash CTManual m return $ \c -> do bounds <- askDBState kmStatementInterval let curRes = lookupCurrency u let go Amount {amtWhen, amtValue, amtDesc} = do @@ -62,11 +53,11 @@ readHistStmt :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement - -> m (Either CommitR [Tx CommitR]) + -> m (Either CommitR [Tx TxCommit]) readHistStmt root i = eitherHash CTImport i return $ \c -> do bs <- readImport root i bounds <- askDBState kmStatementInterval - return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs + return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = HistoryCommit c}) bs splitHistory :: [History] -> ([HistTransfer], [Statement]) splitHistory = partitionEithers . fmap go @@ -74,17 +65,35 @@ splitHistory = partitionEithers . fmap go go (HistTransfer x) = Left x go (HistStatement x) = Right x -insertHistory +insertAll :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) - => [EntryBin CommitR] + => [EntryBin] -> m () -insertHistory hs = do - (toUpdate, toInsert) <- balanceTxs hs +insertAll ebs = do + (toUpdate, toInsert) <- balanceTxs ebs mapM_ updateTx toUpdate - forM_ (groupKey commitRHash $ (\x -> (itxCommit x, x)) <$> toInsert) $ + forM_ (groupWith itxCommit toInsert) $ \(c, ts) -> do - ck <- insert c + ck <- insert $ getCommit c mapM_ (insertTx ck) ts + where + getCommit (HistoryCommit c) = c + getCommit (BudgetCommit c _) = c + +insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m () +insertTx c InsertTx {itxDate, itxDescr, itxEntries, itxCommit} = do + let anyDeferred = any (isJust . feDeferred) itxEntries + k <- insert $ TransactionR c itxDate itxDescr anyDeferred + mapM_ (go k) itxEntries + where + go k tx = do + ek <- insertEntry k tx + case itxCommit of + BudgetCommit _ name -> insert_ $ BudgetLabelR ek name + _ -> return () + +updateTx :: MonadSqlQuery m => UEBalanced -> m () +updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue ueValue] -------------------------------------------------------------------------------- -- low-level transaction stuff @@ -98,12 +107,12 @@ txPair -> CurrencyPrec -> TransferValue -> T.Text - -> Tx CommitR + -> Tx TxCommit txPair commit day from to cur (TransferValue t v) desc = Tx { txDescr = desc , txDate = day - , txCommit = commit + , txCommit = HistoryCommit commit , txPrimary = EntrySet { esTotalValue = EntryValue t $ toRational v @@ -126,15 +135,6 @@ txPair commit day from to cur (TransferValue t v) desc = -- resolveTx t@Tx {txEntries = ss} = -- (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss -insertTx :: MonadSqlQuery m => CommitRId -> InsertTx CommitR -> m () -insertTx c InsertTx {itxDate = d, itxDescr = e, itxEntries = ss} = do - let anyDeferred = any (isJust . feDeferred) ss - k <- insert $ TransactionR c d e anyDeferred - mapM_ (insertEntry k) ss - -updateTx :: MonadSqlQuery m => UEBalanced -> m () -updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue ueValue] - -------------------------------------------------------------------------------- -- Statements @@ -349,8 +349,8 @@ matchNonDates ms = go ([], [], initZipper ms) balanceTxs :: (MonadInsertError m, MonadFinance m) - => [EntryBin a] - -> m ([UEBalanced], [InsertTx a]) + => [EntryBin] + -> m ([UEBalanced], [InsertTx]) balanceTxs ebs = first concat . partitionEithers . catMaybes <$> evalStateT (mapErrors go $ L.sortOn binDate ebs) M.empty @@ -379,7 +379,7 @@ balanceTxs ebs = Right (EntryValue t v) -> findBalance eAcnt c t v Left v -> return $ toRational v * tot -binDate :: EntryBin a -> Day +binDate :: EntryBin -> Day binDate (ToUpdate UpdateEntrySet {utDate}) = utDate binDate (ToRead ReadEntry {reDate}) = reDate binDate (ToInsert Tx {txDate}) = txDate diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs index 27fc59f..9df0bc4 100644 --- a/lib/Internal/Types/Database.hs +++ b/lib/Internal/Types/Database.hs @@ -20,7 +20,7 @@ share CommitR sql=commits hash Int type ConfigType - deriving Show Eq + deriving Show Eq Ord CurrencyR sql=currencies symbol T.Text fullname T.Text @@ -67,7 +67,7 @@ BudgetLabelR sql=budget_labels |] data ConfigType = CTBudget | CTManual | CTImport - deriving (Eq, Show, Read, Enum) + deriving (Eq, Show, Read, Enum, Ord) instance PersistFieldSql ConfigType where sqlType _ = SqlString diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index 20b461c..c02606d 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -121,10 +121,10 @@ data UpdateEntrySet = UpdateEntrySet , utTotalValue :: !Rational } -data EntryBin a +data EntryBin = ToUpdate UpdateEntrySet | ToRead ReadEntry - | ToInsert (Tx a) + | ToInsert (Tx TxCommit) data InsertEntry a c t = InsertEntry { feCurrency :: !c @@ -218,6 +218,8 @@ data EntrySet a c t v v' = EntrySet , esTo :: !(HalfEntrySet a c t (LinkDeferred v)) } +data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text deriving (Eq, Ord) + data Tx k = Tx { txDescr :: !T.Text , txDate :: !Day @@ -227,11 +229,11 @@ data Tx k = Tx } deriving (Generic) -data InsertTx a = InsertTx +data InsertTx = InsertTx { itxDescr :: !T.Text , itxDate :: !Day , itxEntries :: ![InsertEntry AccountRId CurrencyRId TagRId] - , itxCommit :: !a + , itxCommit :: !TxCommit } deriving (Generic)