688 lines
22 KiB
Haskell
688 lines
22 KiB
Haskell
module Internal.Database
|
|
( runDB
|
|
, nukeTables
|
|
, updateHashes
|
|
, updateDBState
|
|
, getDBState
|
|
, tree2Records
|
|
, flattenAcntRoot
|
|
, paths2IDs
|
|
, mkPool
|
|
, whenHash0
|
|
, whenHash
|
|
, whenHash_
|
|
, eitherHash
|
|
, insertEntry
|
|
, readUpdates
|
|
, insertAll
|
|
, updateTx
|
|
)
|
|
where
|
|
|
|
import Conduit
|
|
import Control.Monad.Except
|
|
import Control.Monad.Logger
|
|
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
|
|
( delete
|
|
, deleteWhere
|
|
, insert
|
|
, insertKey
|
|
, insert_
|
|
, runMigration
|
|
, update
|
|
, (==.)
|
|
, (||.)
|
|
)
|
|
import GHC.Err
|
|
import Internal.Types.Main
|
|
import Internal.Utils
|
|
import RIO hiding (LogFunc, isNothing, on, (^.))
|
|
import RIO.List ((\\))
|
|
import qualified RIO.List as L
|
|
import qualified RIO.Map as M
|
|
import qualified RIO.NonEmpty as NE
|
|
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
|
|
|
|
hashConfig :: Config -> [Int]
|
|
hashConfig
|
|
Config_
|
|
{ budget = bs
|
|
, statements = ss
|
|
} = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
|
|
where
|
|
(ms, ps) = partitionEithers $ fmap go ss
|
|
go (HistTransfer x) = Left x
|
|
go (HistStatement x) = Right x
|
|
|
|
setDiff :: Eq a => [a] -> [a] -> ([a], [a])
|
|
-- setDiff = setDiff' (==)
|
|
setDiff as bs = (as \\ bs, bs \\ as)
|
|
|
|
-- setDiff' :: Eq a => (a -> b -> Bool) -> [a] -> [b] -> ([a], [b])
|
|
-- setDiff' f = go []
|
|
-- where
|
|
-- go inA [] bs = (inA, bs)
|
|
-- go inA as [] = (as ++ inA, [])
|
|
-- go inA (a:as) bs = case inB a bs of
|
|
-- Just bs' -> go inA as bs'
|
|
-- Nothing -> go (a:inA) as bs
|
|
-- inB _ [] = Nothing
|
|
-- inB a (b:bs)
|
|
-- | f a b = Just bs
|
|
-- | otherwise = inB a bs
|
|
|
|
getDBHashes :: MonadSqlQuery m => m [Int]
|
|
getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
|
|
|
|
nukeDBHash :: MonadSqlQuery m => Int -> m ()
|
|
nukeDBHash h = deleteE $ do
|
|
c <- E.from E.table
|
|
E.where_ (c ^. CommitRHash ==. E.val h)
|
|
|
|
nukeDBHashes :: MonadSqlQuery m => [Int] -> m ()
|
|
nukeDBHashes = mapM_ nukeDBHash
|
|
|
|
getConfigHashes :: MonadSqlQuery m => Config -> m ([Int], [Int])
|
|
getConfigHashes c = do
|
|
let ch = hashConfig c
|
|
dh <- getDBHashes
|
|
return $ setDiff dh ch
|
|
|
|
dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
|
|
dumpTbl = selectE $ E.from E.table
|
|
|
|
deleteAccount :: MonadSqlQuery m => Entity AccountR -> m ()
|
|
deleteAccount e = deleteE $ do
|
|
c <- E.from $ E.table @AccountR
|
|
E.where_ (c ^. AccountRId ==. E.val k)
|
|
where
|
|
k = entityKey e
|
|
|
|
deleteCurrency :: MonadSqlQuery m => Entity CurrencyR -> m ()
|
|
deleteCurrency e = deleteE $ do
|
|
c <- E.from $ E.table @CurrencyR
|
|
E.where_ (c ^. CurrencyRId ==. E.val k)
|
|
where
|
|
k = entityKey e
|
|
|
|
deleteTag :: MonadSqlQuery m => Entity TagR -> m ()
|
|
deleteTag e = deleteE $ do
|
|
c <- E.from $ E.table @TagR
|
|
E.where_ (c ^. TagRId ==. E.val k)
|
|
where
|
|
k = entityKey e
|
|
|
|
-- TODO slip-n-slide code...
|
|
insertFull
|
|
:: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m)
|
|
=> Entity r
|
|
-> m ()
|
|
insertFull (Entity k v) = insertKey k v
|
|
|
|
currency2Record :: Currency -> Entity CurrencyR
|
|
currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
|
|
Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision)
|
|
|
|
currencyMap :: [Entity CurrencyR] -> CurrencyMap
|
|
currencyMap =
|
|
M.fromList
|
|
. fmap
|
|
( \e ->
|
|
( currencyRSymbol $ entityVal e
|
|
, CurrencyPrec (entityKey e) $ fromIntegral $ currencyRPrecision $ entityVal e
|
|
)
|
|
)
|
|
|
|
toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
|
|
toKey = toSqlKey . fromIntegral . hash
|
|
|
|
tree2Entity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR
|
|
tree2Entity t parents name des =
|
|
Entity (toSqlKey $ fromIntegral h) $
|
|
AccountR name (toPath parents) des
|
|
where
|
|
p = AcntPath t (reverse (name : parents))
|
|
h = hash p
|
|
toPath = T.intercalate "/" . (atName t :) . reverse
|
|
|
|
tree2Records
|
|
:: AcntType
|
|
-> AccountTree
|
|
-> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntSign, AcntType))])
|
|
tree2Records t = go []
|
|
where
|
|
go ps (Placeholder d n cs) =
|
|
let e = tree2Entity t (fmap snd ps) n d
|
|
k = entityKey e
|
|
(as, aps, ms) = L.unzip3 $ fmap (go ((k, n) : ps)) cs
|
|
a0 = acnt k n (fmap snd ps) d
|
|
paths = expand k $ fmap fst ps
|
|
in (a0 : concat as, paths ++ concat aps, concat ms)
|
|
go ps (Account d n) =
|
|
let e = tree2Entity t (fmap snd ps) n d
|
|
k = entityKey e
|
|
in ( [acnt k n (fmap snd ps) d]
|
|
, expand k $ fmap fst ps
|
|
, [(AcntPath t $ reverse $ n : fmap snd ps, (k, sign, t))]
|
|
)
|
|
toPath = T.intercalate "/" . (atName t :) . reverse
|
|
acnt k n ps = Entity k . AccountR n (toPath ps)
|
|
expand h0 hs = (\(h, d) -> AccountPathR h h0 d) <$> zip (h0 : hs) [0 ..]
|
|
sign = accountSign t
|
|
|
|
paths2IDs :: [(AcntPath, a)] -> [(AcntID, a)]
|
|
paths2IDs =
|
|
uncurry zip
|
|
. first trimNames
|
|
. L.unzip
|
|
. L.sortOn fst
|
|
. fmap (first pathList)
|
|
where
|
|
pathList (AcntPath t []) = atName t :| []
|
|
pathList (AcntPath t ns) = NE.reverse $ atName t :| ns
|
|
|
|
-- none of these errors should fire assuming that input is sorted and unique
|
|
trimNames :: [NE.NonEmpty T.Text] -> [AcntID]
|
|
trimNames = fmap (T.intercalate "_" . reverse) . trimAll 0
|
|
where
|
|
trimAll _ [] = []
|
|
trimAll i (y : ys) = case L.foldl' (matchPre i) (y, [], []) ys of
|
|
(a, [], bs) -> reverse $ trim i a : bs
|
|
(a, as, bs) -> reverse bs ++ trimAll (i + 1) (reverse $ a : as)
|
|
matchPre i (y, ys, old) new = case (y !? i, new !? i) of
|
|
(Nothing, Just _) ->
|
|
case ys of
|
|
[] -> (new, [], trim i y : old)
|
|
_ -> err "unsorted input"
|
|
(Just _, Nothing) -> err "unsorted input"
|
|
(Nothing, Nothing) -> err "duplicated inputs"
|
|
(Just a, Just b)
|
|
| a == b -> (new, y : ys, old)
|
|
| otherwise ->
|
|
let next = case ys of
|
|
[] -> [trim i y]
|
|
_ -> trimAll (i + 1) (reverse $ y : ys)
|
|
in (new, [], reverse next ++ old)
|
|
trim i = NE.take (i + 1)
|
|
err msg = errorWithoutStackTrace $ "Import.Database.Ops.hs: " ++ msg
|
|
|
|
(!?) :: NE.NonEmpty a -> Int -> Maybe a
|
|
xs !? n
|
|
| n < 0 = Nothing
|
|
-- Definition adapted from GHC.List
|
|
| otherwise =
|
|
foldr
|
|
( \x r k -> case k of
|
|
0 -> Just x
|
|
_ -> r (k - 1)
|
|
)
|
|
(const Nothing)
|
|
xs
|
|
n
|
|
|
|
flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)]
|
|
flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arEquity} =
|
|
((IncomeT,) <$> arIncome)
|
|
++ ((ExpenseT,) <$> arExpenses)
|
|
++ ((LiabilityT,) <$> arLiabilities)
|
|
++ ((AssetT,) <$> arAssets)
|
|
++ ((EquityT,) <$> arEquity)
|
|
|
|
indexAcntRoot :: AccountRoot -> ([Entity AccountR], [AccountPathR], AccountMap)
|
|
indexAcntRoot r =
|
|
( concat ars
|
|
, concat aprs
|
|
, M.fromList $ paths2IDs $ concat ms
|
|
)
|
|
where
|
|
(ars, aprs, ms) = L.unzip3 $ uncurry tree2Records <$> flattenAcntRoot r
|
|
|
|
getDBState
|
|
:: (MonadInsertError m, MonadSqlQuery m)
|
|
=> Config
|
|
-> m (DBState, DBUpdates)
|
|
getDBState c = do
|
|
(del, new) <- getConfigHashes c
|
|
combineError bi si $ \b s ->
|
|
( DBState
|
|
{ kmCurrency = currencyMap cs
|
|
, kmAccount = am
|
|
, kmBudgetInterval = b
|
|
, kmStatementInterval = s
|
|
, kmTag = tagMap ts
|
|
, kmNewCommits = new
|
|
}
|
|
, DBUpdates
|
|
{ duOldCommits = del
|
|
, duNewTagIds = ts
|
|
, duNewAcntPaths = paths
|
|
, duNewAcntIds = acnts
|
|
, duNewCurrencyIds = cs
|
|
}
|
|
)
|
|
where
|
|
bi = liftExcept $ resolveDaySpan $ budgetInterval $ global c
|
|
si = liftExcept $ resolveDaySpan $ statementInterval $ global c
|
|
(acnts, paths, am) = indexAcntRoot $ accounts c
|
|
cs = currency2Record <$> currencies c
|
|
ts = toRecord <$> tags c
|
|
toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
|
|
tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
|
|
|
|
updateHashes :: (MonadSqlQuery m) => DBUpdates -> m ()
|
|
updateHashes DBUpdates {duOldCommits} = nukeDBHashes duOldCommits
|
|
|
|
updateTags :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
|
|
updateTags DBUpdates {duNewTagIds} = do
|
|
tags' <- selectE $ E.from $ E.table @TagR
|
|
let (toIns, toDel) = setDiff duNewTagIds tags'
|
|
mapM_ deleteTag toDel
|
|
mapM_ insertFull toIns
|
|
|
|
updateAccounts :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
|
|
updateAccounts DBUpdates {duNewAcntIds, duNewAcntPaths} = do
|
|
acnts' <- dumpTbl
|
|
let (toIns, toDel) = setDiff duNewAcntIds acnts'
|
|
deleteWhere ([] :: [Filter AccountPathR])
|
|
mapM_ deleteAccount toDel
|
|
mapM_ insertFull toIns
|
|
mapM_ insert duNewAcntPaths
|
|
|
|
updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
|
|
updateCurrencies DBUpdates {duNewCurrencyIds} = do
|
|
curs' <- selectE $ E.from $ E.table @CurrencyR
|
|
let (toIns, toDel) = setDiff duNewCurrencyIds curs'
|
|
mapM_ deleteCurrency toDel
|
|
mapM_ insertFull toIns
|
|
|
|
updateDBState :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
|
|
updateDBState u = do
|
|
updateHashes u
|
|
updateTags u
|
|
updateAccounts u
|
|
updateCurrencies u
|
|
|
|
deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
|
|
deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
|
|
|
|
selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r]
|
|
selectE q = unsafeLiftSql "esqueleto-select" (E.select q)
|
|
|
|
whenHash
|
|
:: (Hashable a, MonadFinance m, MonadSqlQuery m)
|
|
=> ConfigType
|
|
-> a
|
|
-> b
|
|
-> (CommitRId -> m b)
|
|
-> m b
|
|
whenHash t o def f = do
|
|
let h = hash o
|
|
hs <- askDBState kmNewCommits
|
|
if h `elem` hs then f =<< insert (CommitR h t) else return def
|
|
|
|
whenHash0
|
|
:: (Hashable a, MonadFinance m)
|
|
=> ConfigType
|
|
-> a
|
|
-> b
|
|
-> (CommitR -> m b)
|
|
-> m b
|
|
whenHash0 t o def f = do
|
|
let h = hash o
|
|
hs <- askDBState kmNewCommits
|
|
if h `elem` hs then f (CommitR h t) else return def
|
|
|
|
eitherHash
|
|
:: (Hashable a, MonadFinance m)
|
|
=> ConfigType
|
|
-> a
|
|
-> (CommitR -> m b)
|
|
-> (CommitR -> m c)
|
|
-> m (Either b c)
|
|
eitherHash t o f g = do
|
|
let h = hash o
|
|
let c = CommitR h t
|
|
hs <- askDBState kmNewCommits
|
|
if h `elem` hs then Right <$> g c else Left <$> f c
|
|
|
|
whenHash_
|
|
:: (Hashable a, MonadFinance m)
|
|
=> ConfigType
|
|
-> a
|
|
-> m b
|
|
-> m (Maybe (CommitR, b))
|
|
whenHash_ t o f = do
|
|
let h = hash o
|
|
let c = CommitR h t
|
|
hs <- askDBState kmNewCommits
|
|
if h `elem` hs then Just . (c,) <$> f else return Nothing
|
|
|
|
-- resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry
|
|
-- resolveEntry s@InsertEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency} = do
|
|
-- let aRes = lookupAccountKey eAcnt
|
|
-- let cRes = lookupCurrencyKey feCurrency
|
|
-- let sRes = lookupAccountSign eAcnt
|
|
-- let tagRes = combineErrors $ fmap lookupTag eTags
|
|
-- -- TODO correct sign here?
|
|
-- -- TODO lenses would be nice here
|
|
-- combineError (combineError3 aRes cRes sRes (,,)) tagRes $
|
|
-- \(aid, cid, sign) tags ->
|
|
-- s
|
|
-- { feCurrency = cid
|
|
-- , feEntry = e {eAcnt = aid, eValue = fromIntegral (sign2Int sign) * eValue, eTags = tags}
|
|
-- }
|
|
|
|
readUpdates
|
|
:: (MonadInsertError m, MonadSqlQuery m)
|
|
=> [Int]
|
|
-> m ([ReadEntry], [Either TotalUpdateEntrySet FullUpdateEntrySet])
|
|
readUpdates hashes = do
|
|
xs <- selectE $ do
|
|
(commits :& txs :& entrysets :& entries) <-
|
|
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.where_ $ commits ^. CommitRHash `E.in_` E.valList hashes
|
|
return
|
|
( entrysets ^. EntrySetRRebalance
|
|
,
|
|
(
|
|
( entrysets ^. EntrySetRId
|
|
, txs ^. TransactionRDate
|
|
, entrysets ^. EntrySetRCurrency
|
|
)
|
|
, entries
|
|
)
|
|
)
|
|
let (toUpdate, toRead) = L.partition (E.unValue . fst) xs
|
|
toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _) -> i) (snd <$> toUpdate)
|
|
return (makeRE . snd <$> toRead, toUpdate')
|
|
where
|
|
makeUES ((_, day, curID), es) = do
|
|
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 $ NE.reverse froms
|
|
(from0', fromUnk, to0, toRO, toUnk) <- splitTo from0 fromUnkVec tos
|
|
-- TODO WAP (wet ass programming)
|
|
return $ case from0' of
|
|
Left x ->
|
|
Left $
|
|
UpdateEntrySet
|
|
{ utDate = E.unValue day
|
|
, utCurrency = E.unValue curID
|
|
, utFrom0 = x
|
|
, utTo0 = to0
|
|
, utFromRO = fromRO
|
|
, utToRO = toRO
|
|
, utFromUnk = fromUnk
|
|
, utToUnk = toUnk
|
|
, utTotalValue = tot
|
|
}
|
|
Right x ->
|
|
Right $
|
|
UpdateEntrySet
|
|
{ utDate = E.unValue day
|
|
, utCurrency = E.unValue curID
|
|
, utFrom0 = x
|
|
, utTo0 = to0
|
|
, utFromRO = fromRO
|
|
, utToRO = toRO
|
|
, utFromUnk = fromUnk
|
|
, utToUnk = toUnk
|
|
, utTotalValue = ()
|
|
}
|
|
_ -> throwError undefined
|
|
makeRE ((_, day, curID), entry) =
|
|
let e = entityVal entry
|
|
in ReadEntry
|
|
{ reDate = E.unValue day
|
|
, reCurrency = E.unValue curID
|
|
, reAcnt = entryRAccount e
|
|
, reValue = entryRValue e
|
|
}
|
|
|
|
splitFrom
|
|
:: NonEmpty (EntryRId, EntryR)
|
|
-> InsertExcept (Either UEBlank (Either UE_RO UEUnk), [UE_RO], [UEUnk])
|
|
splitFrom (f0 :| fs) = do
|
|
-- ASSUME entries are sorted by index
|
|
-- TODO combine errors here
|
|
let f0Res = readDeferredValue f0
|
|
let fsRes = mapErrors splitDeferredValue 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
|
|
:: Either UEBlank (Either UE_RO UEUnk)
|
|
-> [UEUnk]
|
|
-> NonEmpty (EntryRId, EntryR)
|
|
-> InsertExcept
|
|
( Either (UEBlank, [UELink]) (Either UE_RO (UEUnk, [UELink]))
|
|
, [(UEUnk, [UELink])]
|
|
, UEBlank
|
|
, [UE_RO]
|
|
, [UEUnk]
|
|
)
|
|
splitTo 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 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 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 . 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
|
|
|
|
-- ASSUME from and toLinked are sorted according to index and 'fst' respectively
|
|
zipPaired
|
|
:: [UEUnk]
|
|
-> [(Int, NonEmpty (EntryRId, EntryR))]
|
|
-> InsertExcept ([(UEUnk, [UELink])], [UE_RO])
|
|
zipPaired = go ([], [])
|
|
where
|
|
go (facc, tacc) (f : fs) ((ti, tls) : ts)
|
|
| ueIndex f == ti = do
|
|
tls' <- mapErrors makeLinkUnk tls
|
|
go ((f, NE.toList tls') : facc, tacc) fs ts
|
|
| otherwise = go ((f, []) : facc, tacc ++ toRO tls) fs ts
|
|
go (facc, tacc) fs ts =
|
|
return
|
|
( reverse facc ++ ((,[]) <$> fs)
|
|
, tacc ++ concatMap (toRO . snd) ts
|
|
)
|
|
toRO = NE.toList . fmap (makeRoUE . snd)
|
|
|
|
makeLinkUnk :: (EntryRId, EntryR) -> InsertExcept UELink
|
|
makeLinkUnk (k, e) =
|
|
maybe
|
|
(throwError $ InsertException undefined)
|
|
(return . makeUE k e . LinkScale)
|
|
$ entryRCachedValue e
|
|
|
|
splitDeferredValue :: (EntryRId, EntryR) -> InsertExcept (Either UE_RO UEUnk)
|
|
splitDeferredValue p = do
|
|
res <- readDeferredValue p
|
|
case res of
|
|
Left _ -> throwError $ InsertException undefined
|
|
Right x -> return x
|
|
|
|
readDeferredValue :: (EntryRId, EntryR) -> InsertExcept (Either UEBlank (Either UE_RO UEUnk))
|
|
readDeferredValue (k, e) = case (entryRCachedValue e, entryRCachedType e) of
|
|
(Nothing, Just TFixed) -> return $ Right $ Left $ makeRoUE e
|
|
(Just v, Just TBalance) -> go EVBalance v
|
|
(Just v, Just TPercent) -> go EVPercent v
|
|
(Nothing, Nothing) -> return $ Left $ makeUnkUE k e
|
|
_ -> throwError $ InsertException undefined
|
|
where
|
|
go c = return . Right . Right . fmap c . makeUE k e
|
|
|
|
makeUE :: i -> EntryR -> v -> UpdateEntry i v
|
|
makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
|
|
|
|
makeRoUE :: EntryR -> UpdateEntry () StaticValue
|
|
makeRoUE e = makeUE () e $ StaticValue (entryRValue e)
|
|
|
|
makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
|
|
makeUnkUE k e = makeUE k e ()
|
|
|
|
insertAll
|
|
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
|
=> [EntryBin]
|
|
-> m ()
|
|
insertAll ebs = do
|
|
(toUpdate, toInsert) <- balanceTxs ebs
|
|
mapM_ updateTx toUpdate
|
|
forM_ (groupWith itxCommit toInsert) $
|
|
\(c, ts) -> do
|
|
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, itxEntrySets, itxCommit} = do
|
|
k <- insert $ TransactionR c itxDate itxDescr
|
|
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 . ieDeferred) (fs ++ ts)
|
|
esk <- insert $ EntrySetR tk iesCurrency i rebalance
|
|
mapM_ (uncurry (go esk)) $ zip [0 ..] ts ++ zip (negate <$> [1 ..]) fs
|
|
go k i e = do
|
|
ek <- insertEntry k i e
|
|
case itxCommit of
|
|
BudgetCommit _ name -> insert_ $ BudgetLabelR ek name
|
|
_ -> return ()
|
|
|
|
insertEntry :: MonadSqlQuery m => EntrySetRId -> Int -> KeyEntry -> m EntryRId
|
|
insertEntry
|
|
k
|
|
i
|
|
InsertEntry
|
|
{ ieEntry = Entry {eValue, eTags, eAcnt, eComment}
|
|
, ieDeferred
|
|
} =
|
|
do
|
|
ek <- insert $ EntryR k eAcnt eComment eValue i cval ctype deflink
|
|
mapM_ (insert_ . TagRelationR ek) eTags
|
|
return ek
|
|
where
|
|
(cval, ctype, deflink) = case ieDeferred of
|
|
(Just (EntryLinked index scale)) -> (Just scale, Nothing, Just $ fromIntegral index)
|
|
(Just (EntryBalance target)) -> (Just target, Just TBalance, Nothing)
|
|
(Just (EntryPercent target)) -> (Just target, Just TPercent, Nothing)
|
|
Nothing -> (Nothing, Just TFixed, Nothing)
|
|
|
|
updateTx :: MonadSqlQuery m => UEBalanced -> m ()
|
|
updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue ueValue]
|