FIX mixed up account paths/keys
This commit is contained in:
parent
0e74ae41db
commit
223be34145
|
|
@ -20,6 +20,7 @@ import Internal.Utils
|
|||
import Options.Applicative
|
||||
import RIO
|
||||
import RIO.FilePath
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.Text as T
|
||||
|
||||
main :: IO ()
|
||||
|
|
@ -232,6 +233,8 @@ runSync threads c bs hs = do
|
|||
-- TODO for some mysterious reason using multithreading just for this
|
||||
-- little bit slows the program down by several seconds
|
||||
-- lift $ setNumCapabilities threads
|
||||
(liftIO . print) =<< askDBState (M.keys . csAccountMap)
|
||||
-- (liftIO . print) =<< askDBState (fmap (accountRFullpath . E.entityVal) . coCreate . csAccounts)
|
||||
(CRUDOps hSs _ _ _) <- askDBState csHistStmts
|
||||
hSs' <- mapErrorsIO (readHistStmt root) hSs
|
||||
-- lift $ setNumCapabilities 1
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ module Internal.Database
|
|||
, nukeTables
|
||||
, updateHashes
|
||||
, updateDBState
|
||||
, getDBState
|
||||
-- , getDBState
|
||||
, tree2Records
|
||||
, flattenAcntRoot
|
||||
, indexAcntRoot
|
||||
|
|
@ -289,22 +289,22 @@ readCurrentCommits = do
|
|||
CTTransfer -> (bs, y : ts, hs)
|
||||
CTHistory -> (bs, ts, y : hs)
|
||||
|
||||
hashConfig :: [Budget] -> [History] -> [Int]
|
||||
hashConfig bs hs = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
|
||||
where
|
||||
(ms, ps) = partitionEithers $ fmap go hs
|
||||
go (HistTransfer x) = Left x
|
||||
go (HistStatement x) = Right x
|
||||
-- hashConfig :: [Budget] -> [History] -> [Int]
|
||||
-- hashConfig bs hs = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
|
||||
-- where
|
||||
-- (ms, ps) = partitionEithers $ fmap go hs
|
||||
-- go (HistTransfer x) = Left x
|
||||
-- go (HistStatement x) = Right x
|
||||
|
||||
setDiff2 :: Eq a => [a] -> [a] -> ([a], [a])
|
||||
setDiff2 = setDiffWith2 (==)
|
||||
-- setDiff2 :: Eq a => [a] -> [a] -> ([a], [a])
|
||||
-- setDiff2 = setDiffWith2 (==)
|
||||
|
||||
-- setDiff :: Eq a => [a] -> [a] -> ([a], [a], [a])
|
||||
-- setDiff as bs = let (as', os, bs') = setDiffWith (==) as bs in (as', fst <$> os, bs')
|
||||
-- -- setDiff :: Eq a => [a] -> [a] -> ([a], [a], [a])
|
||||
-- -- setDiff as bs = let (as', os, bs') = setDiffWith (==) as bs in (as', fst <$> os, bs')
|
||||
|
||||
-- setDiff as bs = (as \\ bs, bs \\ as)
|
||||
setDiffWith2 :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [b])
|
||||
setDiffWith2 f as bs = let (as', _, bs') = setDiffWith f as bs in (as', bs')
|
||||
-- -- setDiff as bs = (as \\ bs, bs \\ as)
|
||||
-- setDiffWith2 :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [b])
|
||||
-- setDiffWith2 f as bs = let (as', _, bs') = setDiffWith f as bs in (as', bs')
|
||||
|
||||
setDiffWith :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [(a, b)], [b])
|
||||
setDiffWith f = go [] []
|
||||
|
|
@ -319,8 +319,8 @@ setDiffWith f = go [] []
|
|||
| f a b = Just (b, bs)
|
||||
| otherwise = inB a bs
|
||||
|
||||
getDBHashes :: MonadSqlQuery m => m [Int]
|
||||
getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
|
||||
-- getDBHashes :: MonadSqlQuery m => m [Int]
|
||||
-- getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
|
||||
|
||||
nukeDBHash :: MonadSqlQuery m => Int -> m ()
|
||||
nukeDBHash h = deleteE $ do
|
||||
|
|
@ -330,11 +330,11 @@ nukeDBHash h = deleteE $ do
|
|||
nukeDBHashes :: MonadSqlQuery m => [Int] -> m ()
|
||||
nukeDBHashes = mapM_ nukeDBHash
|
||||
|
||||
getConfigHashes :: MonadSqlQuery m => [Budget] -> [History] -> m ([Int], [Int])
|
||||
getConfigHashes bs hs = do
|
||||
let ch = hashConfig bs hs
|
||||
dh <- getDBHashes
|
||||
return $ setDiff2 dh ch
|
||||
-- getConfigHashes :: MonadSqlQuery m => [Budget] -> [History] -> m ([Int], [Int])
|
||||
-- getConfigHashes bs hs = do
|
||||
-- let ch = hashConfig bs hs
|
||||
-- dh <- getDBHashes
|
||||
-- return $ setDiff2 dh ch
|
||||
|
||||
dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
|
||||
dumpTbl = selectE $ E.from E.table
|
||||
|
|
@ -380,30 +380,32 @@ currencyMap =
|
|||
toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
|
||||
toKey = toSqlKey . fromIntegral . hash
|
||||
|
||||
parentEntity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR
|
||||
parentEntity t parents name des =
|
||||
Entity (toSqlKey $ fromIntegral h) $ AccountR name p des (accountSign t) False
|
||||
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
|
||||
p = AcntPath t (name : parents)
|
||||
h = hash p
|
||||
path = AcntPath atype (reverse $ name : parents)
|
||||
|
||||
tree2Records :: AcntType -> AccountTree -> ([Entity AccountR], [Entity AccountPathR])
|
||||
tree2Records t = go []
|
||||
where
|
||||
go ps (Placeholder d n cs) =
|
||||
let e = parentEntity t (fmap snd ps) n d
|
||||
k = entityKey e
|
||||
(as, aps) = L.unzip $ 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)
|
||||
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 e = parentEntity t (fmap snd ps) n d
|
||||
k = entityKey e
|
||||
in ([acnt k n (fmap snd ps) d], expand k $ fmap fst ps)
|
||||
acnt k n ps desc = Entity k $ AccountR n (AcntPath t (n : ps)) desc sign True
|
||||
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 ..]
|
||||
sign = accountSign t
|
||||
acnt n ps d = makeAccountEntity . makeAccountR t n ps d
|
||||
|
||||
accountPathRecord :: Key AccountR -> Key AccountR -> Int -> Entity AccountPathR
|
||||
accountPathRecord p c d =
|
||||
|
|
@ -415,48 +417,74 @@ paths2IDs =
|
|||
. first trimNames
|
||||
. L.unzip
|
||||
. L.sortOn fst
|
||||
. fmap (first pathList)
|
||||
where
|
||||
pathList (AcntPath t ns) = NE.reverse $ atName t :| reverse ns
|
||||
. fmap (first (NE.reverse . acntPath2NonEmpty))
|
||||
|
||||
-- -- 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
|
||||
|
||||
-- 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
|
||||
trimNames :: [NonEmpty T.Text] -> [AcntID]
|
||||
trimNames = fmap (T.intercalate "_") . go []
|
||||
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
|
||||
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 undefined . NE.nonEmpty) xs
|
||||
in next : other
|
||||
(x :| xs) -> go (key : prev) $ fmap (fromMaybe undefined . NE.nonEmpty) (x : xs)
|
||||
|
||||
(!?) :: 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
|
||||
groupNonEmpty :: Ord a => [NonEmpty a] -> [(a, NonEmpty [a])]
|
||||
groupNonEmpty = fmap (second (NE.tail <$>)) . groupWith NE.head
|
||||
|
||||
-- groupNonEmpty :: Ord a => [NonEmpty a] -> [(a, (Maybe a, [NonEmpty a]))]
|
||||
-- groupNonEmpty = fmap (second (go <$>)) . groupWith NE.head
|
||||
-- where
|
||||
-- go xs = case NE.nonEmpty $ NE.tail xs of
|
||||
-- (x :| [])
|
||||
|
||||
-- where
|
||||
-- go xs@((key :| _) :| _) = (key, xs)
|
||||
|
||||
-- go (x :| xs) = (x, Just xs)
|
||||
|
||||
-- (!?) :: 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} =
|
||||
|
|
@ -479,39 +507,39 @@ makeAcntMap =
|
|||
indexAcntRoot :: AccountRoot -> ([Entity AccountR], [Entity AccountPathR])
|
||||
indexAcntRoot = bimap concat concat . L.unzip . fmap (uncurry tree2Records) . flattenAcntRoot
|
||||
|
||||
getDBState
|
||||
:: (MonadInsertError m, MonadSqlQuery m)
|
||||
=> Config
|
||||
-> [Budget]
|
||||
-> [History]
|
||||
-> m (DBState, DBUpdates)
|
||||
getDBState c bs hs = do
|
||||
(del, new) <- getConfigHashes bs hs
|
||||
combineError bi si $ \b s ->
|
||||
( DBState
|
||||
{ kmCurrency = currencyMap cs
|
||||
, kmAccount = undefined
|
||||
, kmBudgetInterval = b
|
||||
, kmStatementInterval = s
|
||||
, kmTag = tagMap ts
|
||||
, kmNewCommits = new
|
||||
}
|
||||
, DBUpdates
|
||||
{ duOldCommits = del
|
||||
, duNewTagIds = ts
|
||||
, duNewAcntPaths = undefined
|
||||
, duNewAcntIds = acnts
|
||||
, duNewCurrencyIds = cs
|
||||
}
|
||||
)
|
||||
where
|
||||
bi = liftExcept $ resolveDaySpan $ budgetInterval $ scope c
|
||||
si = liftExcept $ resolveDaySpan $ statementInterval $ scope c
|
||||
(acnts, _) = 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))
|
||||
-- getDBState
|
||||
-- :: (MonadInsertError m, MonadSqlQuery m)
|
||||
-- => Config
|
||||
-- -> [Budget]
|
||||
-- -> [History]
|
||||
-- -> m (DBState, DBUpdates)
|
||||
-- getDBState c bs hs = do
|
||||
-- (del, new) <- getConfigHashes bs hs
|
||||
-- combineError bi si $ \b s ->
|
||||
-- ( DBState
|
||||
-- { kmCurrency = currencyMap cs
|
||||
-- , kmAccount = undefined
|
||||
-- , kmBudgetInterval = b
|
||||
-- , kmStatementInterval = s
|
||||
-- , kmTag = tagMap ts
|
||||
-- , kmNewCommits = new
|
||||
-- }
|
||||
-- , DBUpdates
|
||||
-- { duOldCommits = del
|
||||
-- , duNewTagIds = ts
|
||||
-- , duNewAcntPaths = undefined
|
||||
-- , duNewAcntIds = acnts
|
||||
-- , duNewCurrencyIds = cs
|
||||
-- }
|
||||
-- )
|
||||
-- where
|
||||
-- bi = liftExcept $ resolveDaySpan $ budgetInterval $ scope c
|
||||
-- si = liftExcept $ resolveDaySpan $ statementInterval $ scope c
|
||||
-- (acnts, _) = 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
|
||||
|
|
|
|||
|
|
@ -11,6 +11,7 @@ import Database.Persist.Sql hiding (Desc, In, Statement)
|
|||
import Database.Persist.TH
|
||||
import Internal.Types.Dhall
|
||||
import RIO
|
||||
import qualified RIO.NonEmpty as NE
|
||||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
|
||||
|
|
@ -124,16 +125,21 @@ data AcntPath = AcntPath
|
|||
}
|
||||
deriving (Eq, Ord, Show, Hashable, Generic, Read)
|
||||
|
||||
acntPath2Text :: AcntPath -> T.Text
|
||||
acntPath2Text = T.intercalate "/" . NE.toList . acntPath2NonEmpty
|
||||
|
||||
acntPath2NonEmpty :: AcntPath -> NonEmpty T.Text
|
||||
acntPath2NonEmpty (AcntPath t cs) = atName t :| cs
|
||||
|
||||
instance PersistFieldSql AcntPath where
|
||||
sqlType _ = SqlString
|
||||
|
||||
instance PersistField AcntPath where
|
||||
toPersistValue (AcntPath t cs) =
|
||||
PersistText $ T.intercalate "/" $ (atName t :) $ reverse cs
|
||||
toPersistValue = PersistText . acntPath2Text
|
||||
|
||||
fromPersistValue (PersistText v) = case T.split (== '/') v of
|
||||
[] -> Left "path is empty"
|
||||
(x : xs) -> case readMaybe $ T.unpack x of
|
||||
Just t -> Right $ AcntPath t $ reverse xs
|
||||
Just t -> Right $ AcntPath t xs
|
||||
_ -> Left "could not get account type"
|
||||
fromPersistValue _ = Left "not a string"
|
||||
|
|
|
|||
|
|
@ -29,7 +29,6 @@ module Internal.Utils
|
|||
, mapErrorsIO
|
||||
, mapErrorsPooledIO
|
||||
, showError
|
||||
, acntPath2Text
|
||||
, tshow
|
||||
, lookupErr
|
||||
, gregorians
|
||||
|
|
@ -419,9 +418,6 @@ fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
|
|||
txt = T.pack . show
|
||||
pad i c z = T.append (T.replicate (i - T.length z) c) z
|
||||
|
||||
acntPath2Text :: AcntPath -> T.Text
|
||||
acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- error display
|
||||
|
||||
|
|
@ -618,10 +614,10 @@ groupKey f = fmap go . NE.groupAllWith (f . fst)
|
|||
where
|
||||
go xs@((c, _) :| _) = (c, fmap snd xs)
|
||||
|
||||
groupWith :: Ord b => (a -> b) -> [a] -> [(b, [a])]
|
||||
groupWith :: Ord b => (a -> b) -> [a] -> [(b, NonEmpty a)]
|
||||
groupWith f = fmap go . NE.groupAllWith fst . fmap (\x -> (f x, x))
|
||||
where
|
||||
go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
|
||||
go xs@((c, _) :| _) = (c, fmap snd xs)
|
||||
|
||||
mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
|
||||
mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
|
||||
|
|
|
|||
Loading…
Reference in New Issue