pwncash/lib/Internal/Database.hs

887 lines
32 KiB
Haskell
Raw Normal View History

2023-07-20 00:25:33 -04:00
{-# LANGUAGE ImplicitPrelude #-}
module Internal.Database
( runDB
2023-07-20 00:25:33 -04:00
, readDB
, nukeTables
2023-07-20 00:25:33 -04:00
, updateMeta
-- , updateDBState
, tree2Records
, flattenAcntRoot
2023-07-13 23:31:27 -04:00
, indexAcntRoot
, paths2IDs
, mkPool
, insertEntry
2023-06-25 14:26:35 -04:00
, readUpdates
, updateTx
2023-07-20 00:25:33 -04:00
, sync
)
where
import Conduit
import Control.Monad.Except
2023-07-20 00:25:33 -04:00
import Control.Monad.IO.Rerunnable
import Control.Monad.Logger
2023-07-08 00:52:40 -04:00
import Data.Decimal
import Data.Hashable
2023-07-15 23:25:28 -04:00
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
2023-07-13 23:31:27 -04:00
( Statement
, delete
, deleteWhere
, insert
, insertKey
, insert_
, runMigration
, update
, (==.)
, (||.)
)
2023-07-20 00:25:33 -04:00
-- import GHC.Err
import Internal.Budget
import Internal.History
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
2023-07-15 23:25:28 -04:00
import qualified RIO.Set as S
import qualified RIO.Text as T
2023-07-20 00:25:33 -04:00
sync
:: (MonadUnliftIO m, MonadRerunnableIO m)
=> ConnectionPool
-> FilePath
-> Config
-> [Budget]
-> [History]
-> m ()
sync pool root c bs hs = do
-- _ <- askLoggerIO
(meta, txState, budgets, history) <- runSqlQueryT pool $ do
runMigration migrateAll
liftIOExceptT $ readDB c bs hs
-- Read raw transactions according to state. If a transaction is already in
-- the database, don't read it but record the commit so we can update it.
(budgets', history') <-
flip runReaderT txState $ do
-- TODO collect errors here
b <- liftIOExceptT $ readBudgetCRUD budgets
h <- readHistoryCRUD root history
return (b, h)
-- liftIO $ print $ length $ coCreate budgets
liftIO $ print $ length $ fst $ coCreate history
liftIO $ print $ bimap length length $ coCreate history
liftIO $ print $ length $ coRead history
liftIO $ print $ length $ coUpdate history
liftIO $ print $ (\(DeleteTxs e a b c' d) -> (length e, length a, length b, length c', length d)) $ coDelete history
-- liftIO $ print $ length $ M.elems $ tsAccountMap txState
-- liftIO $ print $ length $ M.elems $ tsCurrencyMap txState
-- liftIO $ print $ length $ M.elems $ tsTagMap txState
-- Update the DB.
runSqlQueryT pool $ withTransaction $ flip runReaderT txState $ do
-- NOTE this must come first (unless we defer foreign keys)
updateMeta meta
res <- runExceptT $ do
-- TODO multithread this :)
insertBudgets budgets'
insertHistory history'
-- 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
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
2023-07-20 00:25:33 -04:00
readDB
:: (MonadAppError m, MonadSqlQuery m)
2023-07-13 23:31:27 -04:00
=> Config
-> [Budget]
-> [History]
2023-07-20 00:25:33 -04:00
-> m (MetaCRUD, TxState, PreBudgetCRUD, PreHistoryCRUD)
readDB c bs hs = do
curAcnts <- readCurrentIds
curPaths <- readCurrentIds
curCurs <- readCurrentIds
curTags <- readCurrentIds
2023-07-13 23:31:27 -04:00
(curBgts, curHistTrs, curHistSts) <- readCurrentCommits
2023-07-15 23:25:28 -04:00
let bsRes = BudgetSpan <$> resolveScope budgetInterval
let hsRes = HistorySpan <$> resolveScope statementInterval
combineErrorM bsRes hsRes $ \bscope hscope -> do
2023-07-20 00:25:33 -04:00
-- ASSUME the db must be empty if these are empty
let dbempty = null curAcnts && null curCurs && null curTags
let meta =
MetaCRUD
{ mcCurrencies = makeCD newCurs curCurs
, mcTags = makeCD newTags curTags
, mcAccounts = makeCD newAcnts curAcnts
, mcPaths = makeCD newPaths curPaths
, mcBudgetScope = bscope
, mcHistoryScope = hscope
}
let txS =
TxState
{ tsAccountMap = amap
, tsCurrencyMap = cmap
, tsTagMap = tmap
, tsBudgetScope = bscope
, tsHistoryScope = hscope
}
2023-07-15 23:25:28 -04:00
(bChanged, hChanged) <- readScopeChanged dbempty bscope hscope
2023-07-20 00:25:33 -04:00
budgets <- makeBudgetCRUD existing bs curBgts bChanged
history <- makeStatementCRUD existing (ts, curHistTrs) (ss, curHistSts) hChanged
return (meta, txS, budgets, history)
2023-07-13 23:31:27 -04:00
where
(ts, ss) = splitHistory hs
2023-07-20 00:25:33 -04:00
makeCD new old =
let (cs, _, ds) = setDiffWith (\a b -> E.entityKey a == b) new old
in CRUDOps cs () () ds
2023-07-13 23:31:27 -04:00
(newAcnts, newPaths) = indexAcntRoot $ accounts c
newTags = tag2Record <$> tags c
newCurs = currency2Record <$> currencies c
resolveScope f = liftExcept $ resolveDaySpan $ f $ scope c
2023-07-20 00:25:33 -04:00
amap = makeAcntMap newAcnts
cmap = currencyMap newCurs
tmap = makeTagMap newTags
fromMap f = S.fromList . fmap f . M.elems
existing = ExistingConfig (fromMap fst amap) (fromMap id tmap) (fromMap cpID cmap)
makeBudgetCRUD
:: MonadSqlQuery m
=> ExistingConfig
-> [Budget]
-> [CommitHash]
-> Bool
-> m (CRUDOps [Budget] () () DeleteTxs)
makeBudgetCRUD existing new old scopeChanged = do
(toIns, toDel) <-
if scopeChanged
then (new,) <$> readTxIds old
else do
let (toDelHashes, overlap, toIns) = setDiffHashes old new
toDel <- readTxIds toDelHashes
(toInsRetry, _) <- readInvalidIds existing overlap
return (toIns ++ (snd <$> toInsRetry), toDel)
return $ CRUDOps toIns () () toDel
makeStatementCRUD
:: (MonadAppError m, MonadSqlQuery m)
=> ExistingConfig
-> ([PairedTransfer], [CommitHash])
-> ([Statement], [CommitHash])
-> Bool
-> m
( CRUDOps
([PairedTransfer], [Statement])
[ReadEntry]
[Either TotalUpdateEntrySet FullUpdateEntrySet]
DeleteTxs
)
makeStatementCRUD existing ts ss scopeChanged = do
(toInsTs, toDelTs, validTs) <- uncurry diff ts
(toInsSs, toDelSs, validSs) <- uncurry diff ss
let toDelAllHashes = toDelTs ++ toDelSs
-- 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 (toInsTs, toInsSs, toDelAllHashes, scopeChanged) of
([], [], [], False) -> return ([], [])
_ -> readUpdates $ validTs ++ validSs
toDelAll <- readTxIds toDelAllHashes
return $ CRUDOps (toInsTs, toInsSs) toRead toUpdate toDelAll
where
diff :: (MonadSqlQuery m, Hashable a) => [a] -> [CommitHash] -> m ([a], [CommitHash], [CommitHash])
diff new old = do
let (toDelHashes, overlap, toIns) = setDiffHashes old new
-- 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
(invalid, valid) <- readInvalidIds existing overlap
let (toDelAllHashes, toInsAll) = bimap (toDelHashes ++) (toIns ++) $ L.unzip invalid
return (toInsAll, toDelAllHashes, valid)
setDiffHashes :: Hashable a => [CommitHash] -> [a] -> ([CommitHash], [(CommitHash, a)], [a])
setDiffHashes = setDiffWith (\a b -> CommitHash (hash b) == a)
2023-07-13 23:31:27 -04:00
2023-07-15 23:25:28 -04:00
readScopeChanged
:: (MonadAppError m, MonadSqlQuery m)
2023-07-15 23:25:28 -04:00
=> Bool
-> BudgetSpan
-> HistorySpan
-> m (Bool, Bool)
readScopeChanged dbempty bscope hscope = do
2023-07-13 23:31:27 -04:00
rs <- dumpTbl
-- TODO these errors should only fire when someone messed with the DB
2023-07-13 23:31:27 -04:00
case rs of
[] -> if dbempty then return (True, True) else throwAppError $ DBError DBShouldBeEmpty
2023-07-13 23:31:27 -04:00
[r] -> do
2023-07-15 23:25:28 -04:00
let (ConfigStateR h b) = E.entityVal r
return (bscope /= b, hscope /= h)
_ -> throwAppError $ DBError DBMultiScope
2023-07-13 23:31:27 -04:00
2023-07-16 00:10:49 -04:00
readTxIds :: MonadSqlQuery m => [CommitHash] -> m DeleteTxs
2023-07-13 23:31:27 -04:00
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)
2023-07-20 00:25:33 -04:00
`E.leftJoin` E.table
`E.on` (\(_ :& _ :& _ :& e :& t) -> E.just (e ^. EntryRId) ==. t ?. TagRelationREntry)
2023-07-13 23:31:27 -04:00
E.where_ $ commits ^. CommitRHash `E.in_` E.valList cs
return
2023-07-20 00:25:33 -04:00
( commits ^. CommitRId
, txs ^. TransactionRId
2023-07-13 23:31:27 -04:00
, ess ^. EntrySetRId
, es ^. EntryRId
2023-07-20 00:25:33 -04:00
, ts ?. TagRelationRId
2023-07-13 23:31:27 -04:00
)
2023-07-20 00:25:33 -04:00
let (cms, txs, ss, es, ts) = L.unzip5 xs
2023-07-13 23:31:27 -04:00
return $
DeleteTxs
2023-07-20 00:25:33 -04:00
{ dtCommits = go cms
, dtTxs = go txs
2023-07-13 23:31:27 -04:00
, dtEntrySets = go ss
, dtEntries = go es
2023-07-20 00:25:33 -04:00
, dtTagRelations = catMaybes $ E.unValue <$> ts
2023-07-13 23:31:27 -04:00
}
where
go :: Eq a => [E.Value a] -> [a]
go = fmap (E.unValue . NE.head) . NE.group
makeTagMap :: [Entity TagR] -> TagMap
makeTagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
tag2Record :: Tag -> Entity TagR
2023-07-16 00:10:49 -04:00
tag2Record t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR (TagID tagID) tagDesc
2023-07-13 23:31:27 -04:00
currency2Record :: Currency -> Entity CurrencyR
currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
2023-07-16 00:10:49 -04:00
Entity (toKey c) $ CurrencyR (CurID curSymbol) curFullname (fromIntegral curPrecision)
2023-07-13 23:31:27 -04:00
2023-07-20 00:25:33 -04:00
readCurrentIds :: (PersistEntity a, MonadSqlQuery m) => m [Key a]
2023-07-15 23:25:28 -04:00
readCurrentIds = fmap (E.unValue <$>) $ selectE $ do
2023-07-13 23:31:27 -04:00
rs <- E.from E.table
2023-07-15 23:25:28 -04:00
return (rs ^. E.persistIdField)
2023-07-13 23:31:27 -04:00
2023-07-16 00:10:49 -04:00
readCurrentCommits :: MonadSqlQuery m => m ([CommitHash], [CommitHash], [CommitHash])
2023-07-13 23:31:27 -04:00
readCurrentCommits = do
xs <- selectE $ do
2023-07-20 00:25:33 -04:00
commits <- E.from E.table
return (commits ^. CommitRHash, commits ^. CommitRType)
2023-07-13 23:31:27 -04:00
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)
2023-07-15 23:25:28 -04:00
CTHistoryTransfer -> (bs, y : ts, hs)
CTHistoryStatement -> (bs, ts, y : hs)
2023-07-13 23:31:27 -04:00
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, [])
2023-07-15 23:25:28 -04:00
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
2023-07-15 14:14:23 -04:00
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
2023-07-15 14:14:23 -04:00
path = AcntPath atype (reverse $ name : parents)
2023-07-13 23:31:27 -04:00
tree2Records :: AcntType -> AccountTree -> ([Entity AccountR], [Entity AccountPathR])
tree2Records t = go []
where
go ps (Placeholder d n cs) =
2023-07-15 14:14:23 -04:00
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) =
2023-07-15 14:14:23 -04:00
let (parentKeys, parentNames) = L.unzip ps
a = acnt n parentNames d True
k = entityKey a
in ([a], expand k parentKeys)
2023-07-13 23:31:27 -04:00
expand h0 hs = (\(h, d) -> accountPathRecord h h0 d) <$> zip (h0 : hs) [0 ..]
2023-07-15 14:14:23 -04:00
acnt n ps d = makeAccountEntity . makeAccountR t n ps d
2023-07-13 23:31:27 -04:00
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
2023-07-15 14:14:23 -04:00
. fmap (first (NE.reverse . acntPath2NonEmpty))
-- none of these errors should fire assuming that input is sorted and unique
2023-07-15 14:14:23 -04:00
trimNames :: [NonEmpty T.Text] -> [AcntID]
2023-07-16 00:10:49 -04:00
trimNames = fmap (AcntID . T.intercalate "_") . go []
where
2023-07-15 14:14:23 -04:00
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
2023-07-15 14:14:23 -04:00
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"
2023-07-15 14:14:23 -04:00
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)
2023-07-13 23:31:27 -04:00
makeAcntMap :: [Entity AccountR] -> AccountMap
makeAcntMap =
M.fromList
. paths2IDs
. fmap go
. filter (accountRLeaf . snd)
. fmap (\e -> (E.entityKey e, E.entityVal e))
where
2023-07-13 23:31:27 -04:00
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
2023-07-13 23:31:27 -04:00
updateCD
:: ( MonadSqlQuery m
, PersistRecordBackend a SqlBackend
)
2023-07-20 00:25:33 -04:00
=> EntityCRUDOps a
2023-07-13 23:31:27 -04:00
-> m ()
updateCD (CRUDOps cs () () ds) = do
mapM_ deleteKeyE ds
insertEntityManyE cs
-- TODO defer foreign keys so I don't need to confusingly reverse this stuff
2023-07-13 23:31:27 -04:00
deleteTxs :: MonadSqlQuery m => DeleteTxs -> m ()
2023-07-20 00:25:33 -04:00
deleteTxs DeleteTxs {dtTxs, dtEntrySets, dtEntries, dtTagRelations, dtCommits} = do
2023-07-13 23:31:27 -04:00
mapM_ deleteKeyE dtTagRelations
2023-07-20 00:25:33 -04:00
mapM_ deleteKeyE dtEntries
mapM_ deleteKeyE dtEntrySets
mapM_ deleteKeyE dtTxs
mapM_ deleteKeyE dtCommits
-- 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 . csHistory)
-- b <- asks csBudgetScope
-- h <- asks csHistoryScope
-- repsertE (E.toSqlKey 1) $ ConfigStateR h b
updateMeta :: MonadSqlQuery m => MetaCRUD -> m ()
updateMeta
MetaCRUD
{ mcCurrencies
, mcAccounts
, mcPaths
, mcTags
, mcBudgetScope
, mcHistoryScope
} = do
updateCD mcCurrencies
updateCD mcAccounts
updateCD mcPaths
updateCD mcTags
repsertE (E.toSqlKey 1) $ ConfigStateR mcHistoryScope mcBudgetScope
2023-07-16 00:10:49 -04:00
readInvalidIds
:: MonadSqlQuery m
=> ExistingConfig
-> [(CommitHash, a)]
2023-07-20 00:25:33 -04:00
-> m ([(CommitHash, a)], [CommitHash])
2023-07-13 23:31:27 -04:00
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)
2023-07-15 23:25:28 -04:00
`E.leftJoin` E.table
`E.on` (\(_ :& _ :& _ :& e :& r) -> E.just (e ^. EntryRId) ==. r ?. TagRelationREntry)
2023-07-13 23:31:27 -04:00
E.where_ $ commits ^. CommitRHash `E.in_` E.valList (fmap fst xs)
return
( commits ^. CommitRHash
, entrysets ^. EntrySetRCurrency
, entries ^. EntryRAccount
2023-07-15 23:25:28 -04:00
, tags ?. TagRelationRTag
2023-07-13 23:31:27 -04:00
)
-- TODO there are faster ways to do this; may/may not matter
2023-07-15 23:25:28 -04:00
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]
2023-07-20 00:25:33 -04:00
let invalid = (cs `S.union` as) `S.union` ts
return $ second (fst <$>) $ L.partition ((`S.member` invalid) . fst) xs
2023-07-13 23:31:27 -04:00
where
2023-07-15 23:25:28 -04:00
go existing =
S.fromList
2023-07-13 23:31:27 -04:00
. fmap (E.unValue . fst)
2023-07-20 00:25:33 -04:00
. L.filter (not . all (`S.member` existing) . snd)
2023-07-13 23:31:27 -04:00
. groupKey id
2023-06-25 14:26:35 -04:00
readUpdates
:: (MonadAppError m, MonadSqlQuery m)
2023-07-16 00:10:49 -04:00
=> [CommitHash]
-> m ([ReadEntry], [Either TotalUpdateEntrySet FullUpdateEntrySet])
2023-06-25 14:26:35 -04:00
readUpdates hashes = do
xs <- selectE $ do
2023-07-06 00:05:16 -04:00
(commits :& txs :& entrysets :& entries :& currencies) <-
2023-06-25 14:26:35 -04:00
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)
2023-06-25 14:26:35 -04:00
`E.innerJoin` E.table @EntryR
`E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
2023-07-06 00:05:16 -04:00
`E.innerJoin` E.table @CurrencyR
`E.on` (\(_ :& _ :& es :& _ :& cur) -> es ^. EntrySetRCurrency ==. cur ^. CurrencyRId)
2023-06-25 14:26:35 -04:00
E.where_ $ commits ^. CommitRHash `E.in_` E.valList hashes
return
( entrysets ^. EntrySetRRebalance
,
(
( entrysets ^. EntrySetRId
, entrysets ^. EntrySetRIndex
, txs ^. TransactionRDate
, txs ^. TransactionRPriority
, txs ^. TransactionRDescription
2023-07-06 00:05:16 -04:00
,
( entrysets ^. EntrySetRCurrency
, currencies ^. CurrencyRPrecision
)
)
, entries
)
2023-06-25 14:26:35 -04:00
)
let (toUpdate, toRead) = L.partition (E.unValue . fst) xs
toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _, _, _) -> i) (snd <$> toUpdate)
2023-07-13 23:31:27 -04:00
let toRead' = fmap (makeRE . snd) toRead
return (toRead', toUpdate')
2023-06-25 14:26:35 -04:00
where
makeUES ((_, esi, day, pri, desc, (curID, prec)), es) = do
let sk = TxSortKey (E.unValue day) (E.unValue pri) (E.unValue desc)
2023-07-08 00:52:40 -04:00
let prec' = fromIntegral $ E.unValue prec
2023-07-13 23:31:27 -04:00
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
2023-07-08 00:52:40 -04:00
(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
{ utCurrency = cur
, utFrom0 = x
, utTo0 = to0
, utFromRO = fromRO
, utToRO = toRO
, utFromUnk = fromUnk
, utToUnk = toUnk
, utTotalValue = realFracToDecimalP prec' tot
, utSortKey = sk
, utIndex = E.unValue esi
}
Right x ->
Right $
UpdateEntrySet
{ utCurrency = cur
, utFrom0 = x
, utTo0 = to0
, utFromRO = fromRO
, utToRO = toRO
, utFromUnk = fromUnk
, utToUnk = toUnk
, utTotalValue = ()
, utSortKey = sk
, utIndex = E.unValue esi
}
-- TODO this error is lame
2023-07-20 00:25:33 -04:00
_ -> throwAppError $ DBError DBUpdateUnbalanced
makeRE ((_, esi, day, pri, desc, (curID, prec)), entry) = do
let e = entityVal entry
in ReadEntry
{ reCurrency = E.unValue curID
, reAcnt = entryRAccount e
2023-07-08 00:52:40 -04:00
, reValue = realFracToDecimal (fromIntegral $ E.unValue prec) (entryRValue e)
, reSortKey = TxSortKey (E.unValue day) (E.unValue pri) (E.unValue desc)
, reESIndex = E.unValue esi
, reIndex = entryRIndex e
}
2023-06-25 14:26:35 -04:00
splitFrom
2023-07-08 00:52:40 -04:00
:: Precision
-> NonEmpty (EntryRId, EntryR)
-> AppExcept (Either UEBlank (Either UE_RO UEUnk), [UE_RO], [UEUnk])
2023-07-08 00:52:40 -04:00
splitFrom prec (f0 :| fs) = do
2023-06-25 14:26:35 -04:00
-- ASSUME entries are sorted by index
-- TODO combine errors here
2023-07-08 00:52:40 -04:00
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)
2023-06-25 14:26:35 -04:00
splitTo
2023-07-08 00:52:40 -04:00
:: 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]
2023-06-25 14:26:35 -04:00
)
2023-07-08 00:52:40 -04:00
splitTo prec from0 fromUnk (t0 :| ts) = do
2023-06-25 14:26:35 -04:00
-- 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
2023-06-25 14:26:35 -04:00
-- 2. For unlinked entries, split into read-only and unknown entries
2023-07-08 00:52:40 -04:00
let unlinkedRes = partitionEithers <$> mapErrors (splitDeferredValue prec) unlinked
2023-06-25 14:26:35 -04:00
-- 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
2023-07-08 00:52:40 -04:00
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), [])
2023-07-08 00:52:40 -04:00
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)
2023-06-25 14:26:35 -04:00
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
2023-07-08 00:52:40 -04:00
:: Precision
-> [UEUnk]
2023-07-16 12:15:39 -04:00
-> [(EntryIndex, NonEmpty (EntryRId, EntryR))]
-> AppExcept ([(UEUnk, [UELink])], [UE_RO])
2023-07-08 00:52:40 -04:00
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)
2023-07-08 00:52:40 -04:00
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)
2023-07-08 00:52:40 -04:00
$ fromRational <$> entryRCachedValue e
splitDeferredValue :: Precision -> (EntryRId, EntryR) -> AppExcept (Either UE_RO UEUnk)
splitDeferredValue prec p@(k, _) = do
2023-07-08 00:52:40 -04:00
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))
2023-07-08 00:52:40 -04:00
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
2023-07-08 00:52:40 -04:00
(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
2023-07-20 00:25:33 -04:00
(Nothing, Just TBalance) -> err DBLinkInvalidBalance
(Nothing, Just TPercent) -> err DBLinkInvalidPercent
where
2023-07-08 00:52:40 -04:00
go = return . Right . Right
err = throwAppError . DBError . DBLinkError k
2023-06-25 14:26:35 -04:00
makeUE :: i -> EntryR -> v -> UpdateEntry i v
makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
2023-07-08 00:52:40 -04:00
makeRoUE :: Precision -> EntryR -> UpdateEntry () StaticValue
makeRoUE prec e = makeUE () e $ StaticValue (realFracToDecimalP prec $ entryRValue e)
2023-06-25 14:26:35 -04:00
makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
makeUnkUE k e = makeUE k e ()
2023-07-20 00:25:33 -04:00
-- updateEntries
-- :: (MonadSqlQuery m, MonadFinance m, MonadRerunnableIO m)
-- => [ ( BudgetName
-- , CRUDOps
-- [Tx CommitR]
-- [ReadEntry]
-- [(Either TotalUpdateEntrySet FullUpdateEntrySet)]
-- DeleteTxs
-- )
-- ]
-- -> m ()
-- updateEntries es = do
-- res <- runExceptT $ mapErrors (uncurry insertAll) es
-- void $ rerunnableIO $ fromEither res
insertBudgets
:: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
2023-07-20 00:25:33 -04:00
=> FinalBudgetCRUD
-> m ()
2023-07-20 00:25:33 -04:00
insertBudgets (CRUDOps bs () () ds) = do
deleteTxs ds
mapM_ go bs
where
go (name, cs) = do
-- TODO useless overhead?
(toUpdate, toInsert) <- balanceTxs (ToInsert <$> cs)
mapM_ updateTx toUpdate
forM_ (groupWith (txmCommit . itxMeta) toInsert) $
2023-07-20 00:25:33 -04:00
\(c, ts) -> do
ck <- insert c
mapM_ (insertTx name ck) ts
insertHistory
:: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
=> FinalHistoryCRUD
-> m ()
insertHistory (CRUDOps cs rs us ds) = do
(toUpdate, toInsert) <- balanceTxs $ (ToInsert <$> cs) ++ (ToRead <$> rs) ++ (ToUpdate <$> us)
mapM_ updateTx toUpdate
forM_ (groupWith (txmCommit . itxMeta) toInsert) $
\(c, ts) -> do
ck <- insert c
2023-07-20 00:25:33 -04:00
mapM_ (insertTx historyName ck) ts
deleteTxs ds
-- insertAll
-- :: (MonadAppError m, MonadSqlQuery m, MonadFinance m)
-- => BudgetName
-- -> CRUDOps
-- [Tx CommitR]
-- [ReadEntry]
-- [Either TotalUpdateEntrySet FullUpdateEntrySet]
-- DeleteTxs
-- -> m ()
-- insertAll b (CRUDOps cs rs us ds) = do
-- (toUpdate, toInsert) <- balanceTxs $ (ToInsert <$> cs) ++ (ToRead <$> rs) ++ (ToUpdate <$> us)
-- mapM_ updateTx toUpdate
-- forM_ (groupWith itxCommit toInsert) $
-- \(c, ts) -> do
-- ck <- insert c
-- mapM_ (insertTx b ck) ts
-- deleteTxs ds
insertTx :: MonadSqlQuery m => BudgetName -> CommitRId -> InsertTx -> m ()
insertTx b c InsertTx {itxMeta = TxMeta {txmDate, txmPriority, txmDesc}, itxEntrySets} = do
k <- insert $ TransactionR c txmDate b txmDesc txmPriority
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
2023-07-16 12:51:39 -04:00
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
2023-07-16 12:15:39 -04:00
insertEntry :: MonadSqlQuery m => EntrySetRId -> EntryIndex -> InsertEntry -> m EntryRId
insertEntry
k
i
InsertEntry
{ ieEntry = Entry {eValue, eTags, eAcnt, eComment}
2023-07-16 12:51:39 -04:00
, ieCached
} =
do
2023-07-08 00:52:40 -04:00
ek <- insert $ EntryR k eAcnt eComment (toRational eValue) i cval ctype deflink
mapM_ (insert_ . TagRelationR ek) eTags
return ek
where
2023-07-16 12:51:39 -04:00
(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 ()
2023-07-08 00:52:40 -04:00
updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. v]
where
v = toRational $ unStaticValue ueValue
2023-07-15 23:28:21 -04:00
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)
2023-07-20 00:25:33 -04:00
historyName :: BudgetName
historyName = BudgetName "history"