117 lines
3.3 KiB
Haskell
117 lines
3.3 KiB
Haskell
module Internal.History
|
|
( splitHistory
|
|
, insertHistTransfer
|
|
, readHistStmt
|
|
, insertHistStmt
|
|
)
|
|
where
|
|
|
|
import Control.Monad.Except
|
|
import Database.Persist.Monad
|
|
import Internal.Database.Ops
|
|
import Internal.Statement
|
|
import Internal.Types.Main
|
|
import Internal.Utils
|
|
import RIO hiding (to)
|
|
import qualified RIO.Text as T
|
|
import RIO.Time
|
|
|
|
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
|
|
|
|
insertHistTransfer
|
|
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
|
=> HistTransfer
|
|
-> m ()
|
|
insertHistTransfer
|
|
m@Transfer
|
|
{ transFrom = from
|
|
, transTo = to
|
|
, transCurrency = u
|
|
, transAmounts = amts
|
|
} = do
|
|
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
|
|
|
|
readHistStmt :: (MonadUnliftIO m, MonadFinance m) => Statement -> m (Maybe (CommitR, [KeyTx]))
|
|
readHistStmt i = whenHash_ CTImport i $ do
|
|
bs <- readImport i
|
|
bounds <- askDBState kmStatementInterval
|
|
liftIOExceptT $ mapErrors resolveTx $ filter (inDaySpan 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
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- low-level transaction stuff
|
|
|
|
-- TODO tags here?
|
|
txPair
|
|
:: (MonadInsertError m, MonadFinance m)
|
|
=> Day
|
|
-> AcntID
|
|
-> AcntID
|
|
-> CurID
|
|
-> Rational
|
|
-> T.Text
|
|
-> m KeyTx
|
|
txPair day from to cur val desc = resolveTx tx
|
|
where
|
|
split a v =
|
|
Entry
|
|
{ eAcnt = a
|
|
, eValue = v
|
|
, eComment = ""
|
|
, eCurrency = cur
|
|
, eTags = []
|
|
}
|
|
tx =
|
|
Tx
|
|
{ txDescr = desc
|
|
, txDate = day
|
|
, txEntries = [split from (-val), split to val]
|
|
}
|
|
|
|
resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
|
|
resolveTx t@Tx {txEntries = ss} =
|
|
fmap (\kss -> t {txEntries = kss}) $
|
|
combineErrors $
|
|
fmap resolveEntry ss
|
|
|
|
insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
|
|
insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
|
|
k <- insert $ TransactionR c d e
|
|
mapM_ (insertEntry k) ss
|