diff --git a/app/Main.hs b/app/Main.hs index 4304bc0..3845f45 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -231,36 +231,13 @@ runSync threads c bs hs = do -- the database, don't read it but record the commit so we can update it. toIns <- flip runReaderT state $ 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 - -- lift $ print $ length $ lefts hSs' - -- lift $ print $ length $ rights hSs' (CRUDOps hTs _ _ _) <- askDBState csHistTrans hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs - -- lift $ print $ length $ lefts hTs' (CRUDOps bTs _ _ _) <- askDBState csBudgets bTs' <- liftIOExceptT $ mapErrors readBudget bTs - -- lift $ print $ length $ lefts bTs return $ concat $ hSs' ++ hTs' ++ bTs' - print $ length $ coCreate $ csBudgets state - print $ length $ coCreate $ csHistTrans state - print $ length $ coCreate $ csHistStmts state - print $ length $ coUpdate $ csBudgets state - print $ length $ coUpdate $ csHistTrans state - print $ length $ coUpdate $ csHistStmts state - print $ length $ coRead $ csBudgets state - print $ length $ coRead $ csHistTrans state - print $ length $ coRead $ csHistStmts state - print $ coDelete $ csBudgets state - print $ coDelete $ csHistTrans state - print $ coDelete $ csHistStmts state - -- print $ fmap hash $ coCreate $ csHistStmts state -- Update the DB. runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do @@ -288,8 +265,4 @@ readConfig :: MonadUnliftIO m => FilePath -> m Config readConfig = fmap unfix . readDhall readDhall :: Dhall.FromDhall a => MonadUnliftIO m => FilePath -> m a -readDhall confpath = do - -- tid <- myThreadId - -- liftIO $ print $ show tid - -- liftIO $ print confpath - liftIO $ Dhall.inputFile Dhall.auto confpath +readDhall confpath = liftIO $ Dhall.inputFile Dhall.auto confpath diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs index 507e09c..b41937f 100644 --- a/lib/Internal/Database.hs +++ b/lib/Internal/Database.hs @@ -4,7 +4,6 @@ module Internal.Database , nukeTables , updateHashes , updateDBState - -- , getDBState , tree2Records , flattenAcntRoot , indexAcntRoot @@ -108,16 +107,6 @@ nukeTables = do -- toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name] -- toBal = maybe "???" (fmtRational 2) . unValue --- data TxState = TxState --- { tsBudget :: !(CRUDOps () () () ()) --- , tsHistTransfer :: !(CRUDOps () () () ()) --- , tsHistStatement :: !(CRUDOps () () () ()) --- } - --- readTxState :: (MonadFinance m, MonadUnliftIO m) -> [Budget] -> [History] -> m TxState --- readTxState bs hs = do --- (curBgts, curHistTrs, curHistSts) <- readCurrentCommits - readConfigState :: (MonadInsertError m, MonadSqlQuery m) => Config @@ -285,23 +274,6 @@ readCurrentCommits = do CTHistoryTransfer -> (bs, y : ts, hs) CTHistoryStatement -> (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 - --- 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 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 [] [] where @@ -318,9 +290,6 @@ findDelete f xs = case break f xs of (ys, []) -> (Nothing, ys) (ys, z : zs) -> (Just z, ys ++ zs) --- getDBHashes :: MonadSqlQuery m => m [Int] --- getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl - nukeDBHash :: MonadSqlQuery m => Int -> m () nukeDBHash h = deleteE $ do c <- E.from E.table @@ -329,43 +298,9 @@ 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 - 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 - currencyMap :: [Entity CurrencyR] -> CurrencyMap currencyMap = M.fromList @@ -418,31 +353,6 @@ paths2IDs = . L.sortOn fst . 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 :: [NonEmpty T.Text] -> [AcntID] trimNames = fmap (T.intercalate "_") . go [] @@ -460,31 +370,6 @@ trimNames = fmap (T.intercalate "_") . go [] 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} = ((IncomeT,) <$> arIncome) @@ -506,66 +391,9 @@ 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)) - 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) = setDiff2 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) = setDiff2 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) = setDiff2 duNewCurrencyIds curs' --- mapM_ deleteCurrency toDel --- mapM_ insertFull toIns - updateCD :: ( MonadSqlQuery m , PersistRecordBackend a SqlBackend @@ -597,70 +425,6 @@ updateDBState = do h <- asks csHistoryScope repsertE (E.toSqlKey 1) $ ConfigStateR h b -deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m () -deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q) - -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) - --- 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 - readInvalidIds :: MonadSqlQuery m => ExistingConfig -> [(Int, a)] -> m ([Int], [(Int, a)]) readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do rs <- selectE $ do @@ -883,17 +647,6 @@ zipPaired prec = go ([], []) let f = maybe (second (++ ros)) (\u -> first (u :)) nextLink go (f acc') fs' ts --- 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 --- ) - makeLinkUnk :: (EntryRId, EntryR) -> InsertExcept UELink makeLinkUnk (k, e) = maybe @@ -939,10 +692,6 @@ insertAll ebs = do ck <- insert 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, itxBudget, itxPriority} = do k <- insert $ TransactionR c itxDate itxDescr itxBudget itxPriority @@ -956,10 +705,6 @@ insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget, itxPriority} = mapM_ (uncurry (go esk)) $ zip [0 ..] ts ++ zip (negate <$> [1 ..]) fs go k i e = void $ insertEntry k i e --- case itxCommit of --- BudgetCommit _ name -> insert_ $ BudgetLabelR ek name --- _ -> return () - insertEntry :: MonadSqlQuery m => EntrySetRId -> Int -> InsertEntry -> m EntryRId insertEntry k @@ -983,3 +728,18 @@ updateTx :: MonadSqlQuery m => UEBalanced -> m () updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. v] where v = toRational $ unStaticValue ueValue + +deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m () +deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q) + +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)