743 lines
27 KiB
Haskell
743 lines
27 KiB
Haskell
module Internal.Database
|
|
( runDB
|
|
, readConfigState
|
|
, nukeTables
|
|
, updateDBState
|
|
, tree2Records
|
|
, flattenAcntRoot
|
|
, indexAcntRoot
|
|
, paths2IDs
|
|
, mkPool
|
|
, insertEntry
|
|
, readUpdates
|
|
, insertAll
|
|
, updateTx
|
|
)
|
|
where
|
|
|
|
import Conduit
|
|
import Control.Monad.Except
|
|
import Control.Monad.Logger
|
|
import Data.Decimal
|
|
import Data.Hashable
|
|
import Database.Esqueleto.Experimental ((:&) (..), (==.), (?.), (^.))
|
|
import qualified Database.Esqueleto.Experimental as E
|
|
import Database.Esqueleto.Internal.Internal (SqlSelect)
|
|
import Database.Persist.Monad
|
|
import Database.Persist.Sqlite hiding
|
|
( Statement
|
|
, delete
|
|
, deleteWhere
|
|
, insert
|
|
, insertKey
|
|
, insert_
|
|
, runMigration
|
|
, update
|
|
, (==.)
|
|
, (||.)
|
|
)
|
|
import GHC.Err
|
|
import Internal.Types.Main
|
|
import Internal.Utils
|
|
import RIO hiding (LogFunc, isNothing, on, (^.))
|
|
import qualified RIO.List as L
|
|
import qualified RIO.Map as M
|
|
import qualified RIO.NonEmpty as NE
|
|
import qualified RIO.Set as S
|
|
import qualified RIO.Text as T
|
|
|
|
runDB
|
|
:: MonadUnliftIO m
|
|
=> SqlConfig
|
|
-> SqlQueryT (NoLoggingT m) a
|
|
-> m a
|
|
runDB c more =
|
|
runNoLoggingT $ do
|
|
pool <- mkPool c
|
|
runSqlQueryT pool $ do
|
|
_ <- lift askLoggerIO
|
|
runMigration migrateAll
|
|
more
|
|
|
|
mkPool :: (MonadLoggerIO m, MonadUnliftIO m) => SqlConfig -> m ConnectionPool
|
|
mkPool c = case c of
|
|
Sqlite p -> createSqlitePool p 10
|
|
-- conn <- open p
|
|
-- wrapConnection conn logfn
|
|
Postgres -> error "postgres not implemented"
|
|
|
|
nukeTables :: MonadSqlQuery m => m ()
|
|
nukeTables = do
|
|
deleteWhere ([] :: [Filter CommitR])
|
|
deleteWhere ([] :: [Filter CurrencyR])
|
|
deleteWhere ([] :: [Filter AccountR])
|
|
deleteWhere ([] :: [Filter TransactionR])
|
|
|
|
-- showBalances :: MonadUnliftIO m => SqlPersistT m ()
|
|
-- showBalances = do
|
|
-- xs <- select $ do
|
|
-- (accounts :& splits :& txs) <-
|
|
-- from
|
|
-- $ table @AccountR
|
|
-- `innerJoin` table @SplitR
|
|
-- `on` (\(a :& s) -> a ^. AccountRId ==. s ^. SplitRAccount)
|
|
-- `innerJoin` table @TransactionR
|
|
-- `on` (\(_ :& s :& t) -> s ^. SplitRTransaction ==. t ^. TransactionRId)
|
|
-- where_ $
|
|
-- isNothing (txs ^. TransactionRBucket)
|
|
-- &&. ( (accounts ^. AccountRFullpath `like` val "asset" ++. (%))
|
|
-- ||. (accounts ^. AccountRFullpath `like` val "liability" ++. (%))
|
|
-- )
|
|
-- groupBy (accounts ^. AccountRFullpath, accounts ^. AccountRName)
|
|
-- return
|
|
-- ( accounts ^. AccountRFullpath
|
|
-- , accounts ^. AccountRName
|
|
-- , sum_ $ splits ^. SplitRValue
|
|
-- )
|
|
-- -- TODO super stetchy table printing thingy
|
|
-- liftIO $ do
|
|
-- putStrLn $ T.unpack $ fmt "Account" "Balance"
|
|
-- putStrLn $ T.unpack $ fmt (T.replicate 60 "-") (T.replicate 15 "-")
|
|
-- mapM_ (putStrLn . T.unpack . fmtBalance) xs
|
|
-- where
|
|
-- fmtBalance (path, name, bal) = fmt (toFullPath path name) (toBal bal)
|
|
-- fmt a b = T.unwords ["| ", pad 60 a, " | ", pad 15 b, " |"]
|
|
-- pad n xs = T.append xs $ T.replicate (n - T.length xs) " "
|
|
-- toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name]
|
|
-- toBal = maybe "???" (fmtRational 2) . unValue
|
|
|
|
readConfigState
|
|
:: (MonadAppError m, MonadSqlQuery m)
|
|
=> Config
|
|
-> [Budget]
|
|
-> [History]
|
|
-> m ConfigState
|
|
readConfigState c bs hs = do
|
|
(acnts2Ins, acntsRem, acnts2Del) <- diff newAcnts
|
|
(pathsIns, _, pathsDel) <- diff newPaths
|
|
(curs2Ins, cursRem, curs2Del) <- diff newCurs
|
|
(tags2Ins, tagsRem, tags2Del) <- diff newTags
|
|
let amap = makeAcntMap $ acnts2Ins ++ (fst <$> acntsRem)
|
|
let cmap = currencyMap $ curs2Ins ++ (fst <$> cursRem)
|
|
let tmap = makeTagMap $ tags2Ins ++ (fst <$> tagsRem)
|
|
let fromMap f = S.fromList . fmap f . M.elems
|
|
let existing =
|
|
ExistingConfig (fromMap fst amap) (fromMap id tmap) (fromMap cpID cmap)
|
|
|
|
(curBgts, curHistTrs, curHistSts) <- readCurrentCommits
|
|
-- TODO refine this test to include the whole db (with data already mixed
|
|
-- in this algorithm)
|
|
let bsRes = BudgetSpan <$> resolveScope budgetInterval
|
|
let hsRes = HistorySpan <$> resolveScope statementInterval
|
|
combineErrorM bsRes hsRes $ \bscope hscope -> do
|
|
let dbempty = null $ curBgts ++ curHistTrs ++ curHistSts
|
|
(bChanged, hChanged) <- readScopeChanged dbempty bscope hscope
|
|
bgt <- makeTxCRUD existing bs curBgts bChanged
|
|
hTrans <- makeTxCRUD existing ts curHistTrs hChanged
|
|
hStmt <- makeTxCRUD existing ss curHistSts hChanged
|
|
|
|
return $
|
|
ConfigState
|
|
{ csCurrencies = CRUDOps curs2Ins () () curs2Del
|
|
, csTags = CRUDOps tags2Ins () () tags2Del
|
|
, csAccounts = CRUDOps acnts2Ins () () acnts2Del
|
|
, csPaths = CRUDOps pathsIns () () pathsDel
|
|
, csBudgets = bgt
|
|
, csHistTrans = hTrans
|
|
, csHistStmts = hStmt
|
|
, csAccountMap = amap
|
|
, csCurrencyMap = cmap
|
|
, csTagMap = tmap
|
|
, csBudgetScope = bscope
|
|
, csHistoryScope = hscope
|
|
}
|
|
where
|
|
(ts, ss) = splitHistory hs
|
|
diff new = setDiffWith (\a b -> E.entityKey a == b) new <$> readCurrentIds
|
|
(newAcnts, newPaths) = indexAcntRoot $ accounts c
|
|
newTags = tag2Record <$> tags c
|
|
newCurs = currency2Record <$> currencies c
|
|
resolveScope f = liftExcept $ resolveDaySpan $ f $ scope c
|
|
|
|
readScopeChanged
|
|
:: (MonadAppError m, MonadSqlQuery m)
|
|
=> Bool
|
|
-> BudgetSpan
|
|
-> HistorySpan
|
|
-> m (Bool, Bool)
|
|
readScopeChanged dbempty bscope hscope = do
|
|
rs <- dumpTbl
|
|
-- TODO these errors should only fire when someone messed with the DB
|
|
case rs of
|
|
[] -> if dbempty then return (True, True) else throwAppError $ DBError DBShouldBeEmpty
|
|
[r] -> do
|
|
let (ConfigStateR h b) = E.entityVal r
|
|
return (bscope /= b, hscope /= h)
|
|
_ -> throwAppError $ DBError DBMultiScope
|
|
|
|
makeTxCRUD
|
|
:: (MonadAppError m, MonadSqlQuery m, Hashable a)
|
|
=> ExistingConfig
|
|
-> [a]
|
|
-> [CommitHash]
|
|
-> Bool
|
|
-> m
|
|
( CRUDOps
|
|
[a]
|
|
[ReadEntry]
|
|
[Either TotalUpdateEntrySet FullUpdateEntrySet]
|
|
DeleteTxs
|
|
)
|
|
makeTxCRUD existing newThings curThings scopeChanged = do
|
|
let (toDelHashes, overlap, toIns) =
|
|
setDiffWith (\a b -> hash b == unCommitHash a) curThings newThings
|
|
-- Check the overlap for rows with accounts/tags/currencies that
|
|
-- won't exist on the next update. Those with invalid IDs will be set aside
|
|
-- to delete and reinsert (which may also fail) later
|
|
(noRetry, toInsRetry) <- readInvalidIds existing overlap
|
|
let (toDelAllHashes, toInsAll) = bimap (toDelHashes ++) (toIns ++) $ L.unzip toInsRetry
|
|
-- If we are inserting or deleting something or the scope changed, pull out
|
|
-- the remainder of the entries to update/read as we are (re)inserting other
|
|
-- stuff (this is necessary because a given transaction may depend on the
|
|
-- value of previous transactions, even if they are already in the DB).
|
|
(toRead, toUpdate) <- case (toInsAll, toDelAllHashes, scopeChanged) of
|
|
([], [], False) -> return ([], [])
|
|
_ -> readUpdates noRetry
|
|
toDelAll <- readTxIds toDelAllHashes
|
|
return $ CRUDOps toInsAll toRead toUpdate toDelAll
|
|
|
|
readTxIds :: MonadSqlQuery m => [CommitHash] -> m DeleteTxs
|
|
readTxIds cs = do
|
|
xs <- selectE $ do
|
|
(commits :& txs :& ess :& es :& ts) <-
|
|
E.from
|
|
$ E.table
|
|
`E.innerJoin` E.table
|
|
`E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit)
|
|
`E.innerJoin` E.table
|
|
`E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
|
|
`E.innerJoin` E.table
|
|
`E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
|
|
`E.innerJoin` E.table
|
|
`E.on` (\(_ :& _ :& _ :& e :& t) -> e ^. EntryRId ==. t ^. TagRelationREntry)
|
|
E.where_ $ commits ^. CommitRHash `E.in_` E.valList cs
|
|
return
|
|
( txs ^. TransactionRId
|
|
, ess ^. EntrySetRId
|
|
, es ^. EntryRId
|
|
, ts ^. TagRelationRId
|
|
)
|
|
let (txs, ss, es, ts) = L.unzip4 xs
|
|
return $
|
|
DeleteTxs
|
|
{ dtTxs = go txs
|
|
, dtEntrySets = go ss
|
|
, dtEntries = go es
|
|
, dtTagRelations = E.unValue <$> ts
|
|
}
|
|
where
|
|
go :: Eq a => [E.Value a] -> [a]
|
|
go = fmap (E.unValue . NE.head) . NE.group
|
|
|
|
splitHistory :: [History] -> ([PairedTransfer], [Statement])
|
|
splitHistory = partitionEithers . fmap go
|
|
where
|
|
go (HistTransfer x) = Left x
|
|
go (HistStatement x) = Right x
|
|
|
|
makeTagMap :: [Entity TagR] -> TagMap
|
|
makeTagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
|
|
|
|
tag2Record :: Tag -> Entity TagR
|
|
tag2Record t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR (TagID tagID) tagDesc
|
|
|
|
currency2Record :: Currency -> Entity CurrencyR
|
|
currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
|
|
Entity (toKey c) $ CurrencyR (CurID curSymbol) curFullname (fromIntegral curPrecision)
|
|
|
|
readCurrentIds :: PersistEntity a => MonadSqlQuery m => m [Key a]
|
|
readCurrentIds = fmap (E.unValue <$>) $ selectE $ do
|
|
rs <- E.from E.table
|
|
return (rs ^. E.persistIdField)
|
|
|
|
readCurrentCommits :: MonadSqlQuery m => m ([CommitHash], [CommitHash], [CommitHash])
|
|
readCurrentCommits = do
|
|
xs <- selectE $ do
|
|
rs <- E.from E.table
|
|
return (rs ^. CommitRHash, rs ^. CommitRType)
|
|
return $ foldr go ([], [], []) xs
|
|
where
|
|
go (x, t) (bs, ts, hs) =
|
|
let y = E.unValue x
|
|
in case E.unValue t of
|
|
CTBudget -> (y : bs, ts, hs)
|
|
CTHistoryTransfer -> (bs, y : ts, hs)
|
|
CTHistoryStatement -> (bs, ts, y : hs)
|
|
|
|
setDiffWith :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [(a, b)], [b])
|
|
setDiffWith f = go [] []
|
|
where
|
|
go inA inBoth [] bs = (inA, inBoth, bs)
|
|
go inA inBoth as [] = (as ++ inA, inBoth, [])
|
|
go inA inBoth (a : as) bs =
|
|
let (res, bs') = findDelete (f a) bs
|
|
in case res of
|
|
Nothing -> go (a : inA) inBoth as bs
|
|
Just b -> go inA ((a, b) : inBoth) as bs'
|
|
|
|
findDelete :: (a -> Bool) -> [a] -> (Maybe a, [a])
|
|
findDelete f xs = case break f xs of
|
|
(ys, []) -> (Nothing, ys)
|
|
(ys, z : zs) -> (Just z, ys ++ zs)
|
|
|
|
dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
|
|
dumpTbl = selectE $ E.from E.table
|
|
|
|
currencyMap :: [Entity CurrencyR] -> CurrencyMap
|
|
currencyMap =
|
|
M.fromList
|
|
. fmap
|
|
( \e ->
|
|
( currencyRSymbol $ entityVal e
|
|
, CurrencyPrec (entityKey e) $ currencyRPrecision $ entityVal e
|
|
)
|
|
)
|
|
|
|
toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
|
|
toKey = toSqlKey . fromIntegral . hash
|
|
|
|
makeAccountEntity :: AccountR -> Entity AccountR
|
|
makeAccountEntity a = Entity (toKey $ accountRFullpath a) a
|
|
|
|
makeAccountR :: AcntType -> T.Text -> [T.Text] -> T.Text -> Bool -> AccountR
|
|
makeAccountR atype name parents des = AccountR name path des (accountSign atype)
|
|
where
|
|
path = AcntPath atype (reverse $ name : parents)
|
|
|
|
tree2Records :: AcntType -> AccountTree -> ([Entity AccountR], [Entity AccountPathR])
|
|
tree2Records t = go []
|
|
where
|
|
go ps (Placeholder d n cs) =
|
|
let (parentKeys, parentNames) = L.unzip ps
|
|
a = acnt n parentNames d False
|
|
k = entityKey a
|
|
thesePaths = expand k parentKeys
|
|
in bimap ((a :) . concat) ((thesePaths ++) . concat) $
|
|
L.unzip $
|
|
go ((k, n) : ps) <$> cs
|
|
go ps (Account d n) =
|
|
let (parentKeys, parentNames) = L.unzip ps
|
|
a = acnt n parentNames d True
|
|
k = entityKey a
|
|
in ([a], expand k parentKeys)
|
|
expand h0 hs = (\(h, d) -> accountPathRecord h h0 d) <$> zip (h0 : hs) [0 ..]
|
|
acnt n ps d = makeAccountEntity . makeAccountR t n ps d
|
|
|
|
accountPathRecord :: Key AccountR -> Key AccountR -> Int -> Entity AccountPathR
|
|
accountPathRecord p c d =
|
|
Entity (toKey (fromSqlKey p, fromSqlKey c)) $ AccountPathR p c d
|
|
|
|
paths2IDs :: [(AcntPath, a)] -> [(AcntID, a)]
|
|
paths2IDs =
|
|
uncurry zip
|
|
. first trimNames
|
|
. L.unzip
|
|
. L.sortOn fst
|
|
. fmap (first (NE.reverse . acntPath2NonEmpty))
|
|
|
|
-- none of these errors should fire assuming that input is sorted and unique
|
|
trimNames :: [NonEmpty T.Text] -> [AcntID]
|
|
trimNames = fmap (AcntID . T.intercalate "_") . go []
|
|
where
|
|
go :: [T.Text] -> [NonEmpty T.Text] -> [[T.Text]]
|
|
go prev = concatMap (go' prev) . groupNonEmpty
|
|
go' prev (key, rest) = case rest of
|
|
(_ :| []) -> [key : prev]
|
|
([] :| xs) ->
|
|
let next = key : prev
|
|
other = go next $ fmap (fromMaybe err . NE.nonEmpty) xs
|
|
in next : other
|
|
(x :| xs) -> go (key : prev) $ fmap (fromMaybe err . NE.nonEmpty) (x : xs)
|
|
err = error "account path list either not sorted or contains duplicates"
|
|
|
|
groupNonEmpty :: Ord a => [NonEmpty a] -> [(a, NonEmpty [a])]
|
|
groupNonEmpty = fmap (second (NE.tail <$>)) . groupWith NE.head
|
|
|
|
flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)]
|
|
flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arEquity} =
|
|
((IncomeT,) <$> arIncome)
|
|
++ ((ExpenseT,) <$> arExpenses)
|
|
++ ((LiabilityT,) <$> arLiabilities)
|
|
++ ((AssetT,) <$> arAssets)
|
|
++ ((EquityT,) <$> arEquity)
|
|
|
|
makeAcntMap :: [Entity AccountR] -> AccountMap
|
|
makeAcntMap =
|
|
M.fromList
|
|
. paths2IDs
|
|
. fmap go
|
|
. filter (accountRLeaf . snd)
|
|
. fmap (\e -> (E.entityKey e, E.entityVal e))
|
|
where
|
|
go (k, v) = let p = accountRFullpath v in (p, (k, apType p))
|
|
|
|
indexAcntRoot :: AccountRoot -> ([Entity AccountR], [Entity AccountPathR])
|
|
indexAcntRoot = bimap concat concat . L.unzip . fmap (uncurry tree2Records) . flattenAcntRoot
|
|
|
|
updateCD
|
|
:: ( MonadSqlQuery m
|
|
, PersistRecordBackend a SqlBackend
|
|
, PersistRecordBackend b SqlBackend
|
|
)
|
|
=> CDOps (Entity a) (Key b)
|
|
-> m ()
|
|
updateCD (CRUDOps cs () () ds) = do
|
|
mapM_ deleteKeyE ds
|
|
insertEntityManyE cs
|
|
|
|
deleteTxs :: MonadSqlQuery m => DeleteTxs -> m ()
|
|
deleteTxs DeleteTxs {dtTxs, dtEntrySets, dtEntries, dtTagRelations} = do
|
|
mapM_ deleteKeyE dtTxs
|
|
mapM_ deleteKeyE dtEntrySets
|
|
mapM_ deleteKeyE dtEntries
|
|
mapM_ deleteKeyE dtTagRelations
|
|
|
|
updateDBState :: (MonadFinance m, MonadSqlQuery m) => m ()
|
|
updateDBState = do
|
|
updateCD =<< asks csCurrencies
|
|
updateCD =<< asks csAccounts
|
|
updateCD =<< asks csPaths
|
|
updateCD =<< asks csTags
|
|
deleteTxs =<< asks (coDelete . csBudgets)
|
|
deleteTxs =<< asks (coDelete . csHistTrans)
|
|
deleteTxs =<< asks (coDelete . csHistStmts)
|
|
b <- asks csBudgetScope
|
|
h <- asks csHistoryScope
|
|
repsertE (E.toSqlKey 1) $ ConfigStateR h b
|
|
|
|
readInvalidIds
|
|
:: MonadSqlQuery m
|
|
=> ExistingConfig
|
|
-> [(CommitHash, a)]
|
|
-> m ([CommitHash], [(CommitHash, a)])
|
|
readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
|
|
rs <- selectE $ do
|
|
(commits :& _ :& entrysets :& entries :& tags) <-
|
|
E.from
|
|
$ E.table
|
|
`E.innerJoin` E.table
|
|
`E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit)
|
|
`E.innerJoin` E.table
|
|
`E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
|
|
`E.innerJoin` E.table
|
|
`E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
|
|
`E.leftJoin` E.table
|
|
`E.on` (\(_ :& _ :& _ :& e :& r) -> E.just (e ^. EntryRId) ==. r ?. TagRelationREntry)
|
|
E.where_ $ commits ^. CommitRHash `E.in_` E.valList (fmap fst xs)
|
|
return
|
|
( commits ^. CommitRHash
|
|
, entrysets ^. EntrySetRCurrency
|
|
, entries ^. EntryRAccount
|
|
, tags ?. TagRelationRTag
|
|
)
|
|
-- TODO there are faster ways to do this; may/may not matter
|
|
let cs = go ecCurrencies $ fmap (\(i, E.Value c, _, _) -> (i, c)) rs
|
|
let as = go ecAccounts $ fmap (\(i, _, E.Value a, _) -> (i, a)) rs
|
|
let ts = go ecTags [(i, t) | (i, _, _, E.Value (Just t)) <- rs]
|
|
let valid = (cs `S.intersection` as) `S.intersection` ts
|
|
let (a0, _) = first (fst <$>) $ L.partition ((`S.member` valid) . fst) xs
|
|
return (a0, [])
|
|
where
|
|
go existing =
|
|
S.fromList
|
|
. fmap (E.unValue . fst)
|
|
. L.filter (all (`S.member` existing) . snd)
|
|
. groupKey id
|
|
|
|
readUpdates
|
|
:: (MonadAppError m, MonadSqlQuery m)
|
|
=> [CommitHash]
|
|
-> m ([ReadEntry], [Either TotalUpdateEntrySet FullUpdateEntrySet])
|
|
readUpdates hashes = do
|
|
xs <- selectE $ do
|
|
(commits :& txs :& entrysets :& entries :& currencies) <-
|
|
E.from
|
|
$ E.table @CommitR
|
|
`E.innerJoin` E.table @TransactionR
|
|
`E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit)
|
|
`E.innerJoin` E.table @EntrySetR
|
|
`E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
|
|
`E.innerJoin` E.table @EntryR
|
|
`E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
|
|
`E.innerJoin` E.table @CurrencyR
|
|
`E.on` (\(_ :& _ :& es :& _ :& cur) -> es ^. EntrySetRCurrency ==. cur ^. CurrencyRId)
|
|
E.where_ $ commits ^. CommitRHash `E.in_` E.valList hashes
|
|
return
|
|
( entrysets ^. EntrySetRRebalance
|
|
,
|
|
(
|
|
( entrysets ^. EntrySetRId
|
|
, txs ^. TransactionRDate
|
|
, txs ^. TransactionRBudgetName
|
|
, txs ^. TransactionRPriority
|
|
,
|
|
( entrysets ^. EntrySetRCurrency
|
|
, currencies ^. CurrencyRPrecision
|
|
)
|
|
)
|
|
, entries
|
|
)
|
|
)
|
|
let (toUpdate, toRead) = L.partition (E.unValue . fst) xs
|
|
toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _, _) -> i) (snd <$> toUpdate)
|
|
let toRead' = fmap (makeRE . snd) toRead
|
|
return (toRead', toUpdate')
|
|
where
|
|
makeUES ((_, day, name, pri, (curID, prec)), es) = do
|
|
let prec' = fromIntegral $ E.unValue prec
|
|
let cur = E.unValue curID
|
|
let res =
|
|
bimap NE.nonEmpty NE.nonEmpty $
|
|
NE.partition ((< 0) . entryRIndex . snd) $
|
|
NE.sortWith (entryRIndex . snd) $
|
|
fmap (\e -> (entityKey e, entityVal e)) es
|
|
case res of
|
|
(Just froms, Just tos) -> do
|
|
let tot = sum $ fmap (entryRValue . snd) froms
|
|
(from0, fromRO, fromUnkVec) <- splitFrom prec' $ NE.reverse froms
|
|
(from0', fromUnk, to0, toRO, toUnk) <- splitTo prec' from0 fromUnkVec tos
|
|
-- TODO WAP (wet ass programming)
|
|
return $ case from0' of
|
|
Left x ->
|
|
Left $
|
|
UpdateEntrySet
|
|
{ utDate = E.unValue day
|
|
, utCurrency = cur
|
|
, utFrom0 = x
|
|
, utTo0 = to0
|
|
, utFromRO = fromRO
|
|
, utToRO = toRO
|
|
, utFromUnk = fromUnk
|
|
, utToUnk = toUnk
|
|
, utTotalValue = realFracToDecimalP prec' tot
|
|
, utBudget = E.unValue name
|
|
, utPriority = E.unValue pri
|
|
}
|
|
Right x ->
|
|
Right $
|
|
UpdateEntrySet
|
|
{ utDate = E.unValue day
|
|
, utCurrency = cur
|
|
, utFrom0 = x
|
|
, utTo0 = to0
|
|
, utFromRO = fromRO
|
|
, utToRO = toRO
|
|
, utFromUnk = fromUnk
|
|
, utToUnk = toUnk
|
|
, utTotalValue = ()
|
|
, utBudget = E.unValue name
|
|
, utPriority = E.unValue pri
|
|
}
|
|
-- TODO this error is lame
|
|
_ -> throwAppError $ DBError $ DBUpdateUnbalanced
|
|
makeRE ((_, day, name, pri, (curID, prec)), entry) = do
|
|
let e = entityVal entry
|
|
in ReadEntry
|
|
{ reDate = E.unValue day
|
|
, reCurrency = E.unValue curID
|
|
, reAcnt = entryRAccount e
|
|
, reValue = realFracToDecimal (fromIntegral $ E.unValue prec) (entryRValue e)
|
|
, reBudget = E.unValue name
|
|
, rePriority = E.unValue pri
|
|
}
|
|
|
|
splitFrom
|
|
:: Precision
|
|
-> NonEmpty (EntryRId, EntryR)
|
|
-> AppExcept (Either UEBlank (Either UE_RO UEUnk), [UE_RO], [UEUnk])
|
|
splitFrom prec (f0 :| fs) = do
|
|
-- ASSUME entries are sorted by index
|
|
-- TODO combine errors here
|
|
let f0Res = readDeferredValue prec f0
|
|
let fsRes = mapErrors (splitDeferredValue prec) fs
|
|
combineErrorM f0Res fsRes $ \f0' fs' -> do
|
|
let (ro, unk) = partitionEithers fs'
|
|
-- let idxVec = V.fromList $ fmap (either (const Nothing) Just) fs'
|
|
return (f0', ro, unk)
|
|
|
|
splitTo
|
|
:: Precision
|
|
-> Either UEBlank (Either UE_RO UEUnk)
|
|
-> [UEUnk]
|
|
-> NonEmpty (EntryRId, EntryR)
|
|
-> AppExcept
|
|
( Either (UEBlank, [UELink]) (Either UE_RO (UEUnk, [UELink]))
|
|
, [(UEUnk, [UELink])]
|
|
, UEBlank
|
|
, [UE_RO]
|
|
, [UEUnk]
|
|
)
|
|
splitTo prec from0 fromUnk (t0 :| ts) = do
|
|
-- How to split the credit side of the database transaction in 1024 easy
|
|
-- steps:
|
|
--
|
|
-- 1. Split incoming entries (except primary) into those with links and not
|
|
let (unlinked, linked) = partitionEithers $ fmap splitLinked ts
|
|
|
|
-- 2. For unlinked entries, split into read-only and unknown entries
|
|
let unlinkedRes = partitionEithers <$> mapErrors (splitDeferredValue prec) unlinked
|
|
|
|
-- 3. For linked entries, split into those that link to the primary debit
|
|
-- entry and not
|
|
let (linked0, linkedN) = second (groupKey id) $ L.partition ((== 0) . fst) linked
|
|
|
|
-- 4. For linked entries that don't link to the primary debit entry, split
|
|
-- into those that link to an unknown debit entry or not. Those that
|
|
-- are not will be read-only and those that are will be collected with
|
|
-- their linked debit entry
|
|
let linkedRes = zipPaired prec fromUnk linkedN
|
|
|
|
-- 5. For entries linked to the primary debit entry, turn them into linked
|
|
-- entries (lazily only used when needed later)
|
|
let from0Res = mapErrors (makeLinkUnk . snd) linked0
|
|
|
|
combineErrorM3 from0Res linkedRes unlinkedRes $
|
|
-- 6. Depending on the type of primary debit entry we have, add linked
|
|
-- entries if it is either an unknown or a blank (to be solved) entry,
|
|
-- or turn the remaining linked entries to read-only and add to the other
|
|
-- read-only entries
|
|
\from0Links (fromUnk', toROLinkedN) (toROUnlinked, toUnk) -> do
|
|
let (from0', toROLinked0) = case from0 of
|
|
Left blnk -> (Left (blnk, from0Links), [])
|
|
Right (Left ro) -> (Right $ Left ro, makeRoUE prec . snd . snd <$> linked0)
|
|
Right (Right unk) -> (Right $ Right (unk, from0Links), [])
|
|
return (from0', fromUnk', primary, toROLinked0 ++ toROLinkedN ++ toROUnlinked, toUnk)
|
|
where
|
|
primary = uncurry makeUnkUE t0
|
|
splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRCachedLink e
|
|
|
|
-- | Match linked credit entries with unknown entries, returning a list of
|
|
-- matches and non-matching (read-only) credit entries. ASSUME both lists are
|
|
-- sorted according to index and 'fst' respectively. NOTE the output will NOT be
|
|
-- sorted.
|
|
zipPaired
|
|
:: Precision
|
|
-> [UEUnk]
|
|
-> [(EntryIndex, NonEmpty (EntryRId, EntryR))]
|
|
-> AppExcept ([(UEUnk, [UELink])], [UE_RO])
|
|
zipPaired prec = go ([], [])
|
|
where
|
|
nolinks = ((,[]) <$>)
|
|
go acc fs [] = return $ first (nolinks fs ++) acc
|
|
go (facc, tacc) fs ((ti, tls) : ts) = do
|
|
let (lesser, rest) = L.span ((< ti) . ueIndex) fs
|
|
links <- NE.toList <$> mapErrors makeLinkUnk tls
|
|
let (nextLink, fs') = case rest of
|
|
(r0 : rs)
|
|
| ueIndex r0 == ti -> (Just (r0, links), rs)
|
|
| otherwise -> (Nothing, rest)
|
|
_ -> (Nothing, rest)
|
|
let acc' = (nolinks lesser ++ facc, tacc)
|
|
let ros = NE.toList $ makeRoUE prec . snd <$> tls
|
|
let f = maybe (second (++ ros)) (\u -> first (u :)) nextLink
|
|
go (f acc') fs' ts
|
|
|
|
makeLinkUnk :: (EntryRId, EntryR) -> AppExcept UELink
|
|
makeLinkUnk (k, e) =
|
|
-- TODO error should state that scale must be present for a link in the db
|
|
maybe
|
|
(throwAppError $ DBError $ DBLinkError k DBLinkNoScale)
|
|
(return . makeUE k e . LinkScale)
|
|
$ fromRational <$> entryRCachedValue e
|
|
|
|
splitDeferredValue :: Precision -> (EntryRId, EntryR) -> AppExcept (Either UE_RO UEUnk)
|
|
splitDeferredValue prec p@(k, _) = do
|
|
res <- readDeferredValue prec p
|
|
case res of
|
|
Left _ -> throwAppError $ DBError $ DBLinkError k DBLinkNoValue
|
|
Right x -> return x
|
|
|
|
readDeferredValue :: Precision -> (EntryRId, EntryR) -> AppExcept (Either UEBlank (Either UE_RO UEUnk))
|
|
readDeferredValue prec (k, e) = case (entryRCachedValue e, entryRCachedType e) of
|
|
(Nothing, Just TFixed) -> return $ Right $ Left $ makeRoUE prec e
|
|
(Just v, Just TBalance) -> go $ fmap EVBalance $ makeUE k e $ realFracToDecimalP prec v
|
|
(Just v, Just TPercent) -> go $ fmap EVPercent $ makeUE k e $ fromRational v
|
|
(Nothing, Nothing) -> return $ Left $ makeUnkUE k e
|
|
(Just v, Nothing) -> err $ DBLinkInvalidValue v False
|
|
(Just v, Just TFixed) -> err $ DBLinkInvalidValue v True
|
|
(Nothing, Just TBalance) -> err $ DBLinkInvalidBalance
|
|
(Nothing, Just TPercent) -> err $ DBLinkInvalidPercent
|
|
where
|
|
go = return . Right . Right
|
|
err = throwAppError . DBError . DBLinkError k
|
|
|
|
makeUE :: i -> EntryR -> v -> UpdateEntry i v
|
|
makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
|
|
|
|
makeRoUE :: Precision -> EntryR -> UpdateEntry () StaticValue
|
|
makeRoUE prec e = makeUE () e $ StaticValue (realFracToDecimalP prec $ entryRValue e)
|
|
|
|
makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
|
|
makeUnkUE k e = makeUE k e ()
|
|
|
|
insertAll
|
|
:: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
|
|
=> [EntryCRU]
|
|
-> m ()
|
|
insertAll ebs = do
|
|
(toUpdate, toInsert) <- balanceTxs ebs
|
|
mapM_ updateTx toUpdate
|
|
forM_ (groupWith itxCommit toInsert) $
|
|
\(c, ts) -> do
|
|
ck <- insert c
|
|
mapM_ (insertTx ck) ts
|
|
|
|
insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
|
|
insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget, itxPriority} = do
|
|
k <- insert $ TransactionR c itxDate itxDescr itxBudget itxPriority
|
|
mapM_ (uncurry (insertEntrySet k)) $ zip [0 ..] (NE.toList itxEntrySets)
|
|
where
|
|
insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do
|
|
let fs = NE.toList iesFromEntries
|
|
let ts = NE.toList iesToEntries
|
|
let rebalance = any (isJust . ieCached) (fs ++ ts)
|
|
esk <- insert $ EntrySetR tk iesCurrency i rebalance
|
|
mapM_ (uncurry (go esk)) $ zip [0 ..] ts ++ zip (negate <$> [1 ..]) fs
|
|
go k i e = void $ insertEntry k i e
|
|
|
|
insertEntry :: MonadSqlQuery m => EntrySetRId -> EntryIndex -> InsertEntry -> m EntryRId
|
|
insertEntry
|
|
k
|
|
i
|
|
InsertEntry
|
|
{ ieEntry = Entry {eValue, eTags, eAcnt, eComment}
|
|
, ieCached
|
|
} =
|
|
do
|
|
ek <- insert $ EntryR k eAcnt eComment (toRational eValue) i cval ctype deflink
|
|
mapM_ (insert_ . TagRelationR ek) eTags
|
|
return ek
|
|
where
|
|
(cval, ctype, deflink) = case ieCached of
|
|
(Just (CachedLink x s)) -> (Just (toRational s), Nothing, Just x)
|
|
(Just (CachedBalance b)) -> (Just (toRational b), Just TBalance, Nothing)
|
|
(Just (CachedPercent p)) -> (Just (toRational p), Just TPercent, Nothing)
|
|
Nothing -> (Nothing, Just TFixed, Nothing)
|
|
|
|
updateTx :: MonadSqlQuery m => UEBalanced -> m ()
|
|
updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. v]
|
|
where
|
|
v = toRational $ unStaticValue ueValue
|
|
|
|
repsertE :: (MonadSqlQuery m, PersistRecordBackend r SqlBackend) => Key r -> r -> m ()
|
|
repsertE k r = unsafeLiftSql "esqueleto-repsert" (E.repsert k r)
|
|
|
|
selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r]
|
|
selectE q = unsafeLiftSql "esqueleto-select" (E.select q)
|
|
|
|
deleteKeyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => Key a -> m ()
|
|
deleteKeyE q = unsafeLiftSql "esqueleto-deleteKey" (E.deleteKey q)
|
|
|
|
insertEntityManyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => [Entity a] -> m ()
|
|
insertEntityManyE q = unsafeLiftSql "esqueleto-insertEntityMany" (E.insertEntityMany q)
|