WIP use more robust update strategy

app/Main.hs

@@ -9,6 +9,7 @@ import Control.Monad.Logger
 import Control.Monad.Reader
 import Data.Bitraversable
 import qualified Data.Text.IO as TI
+import qualified Database.Esqueleto.Experimental as E
 import Database.Persist.Monad
 import qualified Dhall hiding (double, record)
 import Internal.Budget
@@ -194,14 +195,13 @@ runDumpAccountKeys c = do
   ar <- accounts <$> readConfig c
   let ks =
         paths2IDs $
-          fmap (double . fst) $
+          fmap (double . accountRFullpath . E.entityVal) $
-            concatMap (t3 . uncurry tree2Records) $
+            fst $
-              flattenAcntRoot ar
+              indexAcntRoot ar
   mapM_ (uncurry printPair) ks
   where
     printPair i p = do
       liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", i]
-    t3 (_, _, x) = x
     double x = (x, x)
 
 runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO ()
@@ -221,27 +221,29 @@ runSync threads c bs hs = do
     -- _ <- askLoggerIO
 
     -- Get the current DB state.
-    (state, updates) <- runSqlQueryT pool $ do
+    state <- runSqlQueryT pool $ do
       runMigration migrateAll
-      liftIOExceptT $ getDBState config bs' hs'
+      liftIOExceptT $ readConfigState config 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.
-    (rus, is) <-
+    toIns <-
       flip runReaderT state $ do
-        let (hTs, hSs) = splitHistory hs'
         -- TODO for some mysterious reason using multithreading just for this
         -- little bit slows the program down by several seconds
         -- lift $ setNumCapabilities threads
+        (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'
-        bTs <- liftIOExceptT $ mapErrors readBudget bs'
+        (CRUDOps bTs _ _ _) <- askDBState csBudgets
+        bTs' <- liftIOExceptT $ mapErrors readBudget bTs
         -- lift $ print $ length $ lefts bTs
-        return $ second concat $ partitionEithers $ hSs' ++ hTs' ++ bTs
+        return $ concat $ hSs' ++ hTs' ++ bTs'
     -- print $ length $ kmNewCommits state
     -- print $ length $ duOldCommits updates
     -- print $ length $ duNewTagIds updates
@@ -252,15 +254,12 @@ runSync threads c bs hs = do
     -- Update the DB.
     runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
       -- NOTE this must come first (unless we defer foreign keys)
-      updateDBState updates
+      updateDBState
-      -- TODO skip this entire section if the database won't change (eg length
-      -- of 'is' is zero and there are no commits to delete)
       res <- runExceptT $ do
-        -- TODO taking out the hash is dumb
+        (CRUDOps _ bRs bUs _) <- askDBState csBudgets
-        (rs, ues) <- readUpdates $ fmap commitRHash rus
+        (CRUDOps _ tRs tUs _) <- askDBState csHistTrans
-        -- rerunnableIO $ print ues
+        (CRUDOps _ sRs sUs _) <- askDBState csHistStmts
-        -- rerunnableIO $ print $ length rs
+        let ebs = fmap ToUpdate (bUs ++ tUs ++ sUs) ++ fmap ToRead (bRs ++ tRs ++ sRs) ++ fmap ToInsert toIns
-        let ebs = fmap ToUpdate ues ++ fmap ToRead rs ++ fmap ToInsert is
         insertAll ebs
       -- NOTE this rerunnable thing is a bit misleading; fromEither will throw
       -- whatever error is encountered above in an IO context, but the first

lib/Internal/Budget.hs

@@ -3,7 +3,7 @@ module Internal.Budget (readBudget) where
 import Control.Monad.Except
 import Data.Decimal hiding (allocate)
 import Data.Foldable
-import Internal.Database
+import Data.Hashable
 import Internal.Types.Main
 import Internal.Utils
 import RIO hiding (to)
@@ -13,10 +13,7 @@ import qualified RIO.NonEmpty as NE
 import qualified RIO.Text as T
 import RIO.Time
 
-readBudget
+readBudget :: (MonadInsertError m, MonadFinance m) => Budget -> m [Tx CommitR]
-  :: (MonadInsertError m, MonadFinance m)
-  => Budget
-  -> m (Either CommitR [Tx CommitR])
 readBudget
   b@Budget
     { bgtLabel
@@ -28,18 +25,19 @@ readBudget
     , bgtPosttax
     , bgtInterval
     } =
-    eitherHash CTBudget b return $ \key -> do
+    do
       spanRes <- getSpan
       case spanRes of
         Nothing -> return []
         Just budgetSpan -> do
           (intAllos, _) <- combineError intAlloRes acntRes (,)
-          let res1 = mapErrors (readIncome key bgtLabel intAllos budgetSpan) bgtIncomes
+          let res1 = mapErrors (readIncome c bgtLabel intAllos budgetSpan) bgtIncomes
-          let res2 = expandTransfers key bgtLabel budgetSpan bgtTransfers
+          let res2 = expandTransfers c bgtLabel budgetSpan bgtTransfers
           txs <- combineError (concat <$> res1) res2 (++)
           shadow <- addShadowTransfers bgtShadowTransfers txs
           return $ txs ++ shadow
     where
+      c = CommitR (hash b) CTBudget
       acntRes = mapErrors isNotIncomeAcnt alloAcnts
       intAlloRes = combineError3 pre_ tax_ post_ (,,)
       pre_ = sortAllos bgtPretax
@@ -51,7 +49,7 @@ readBudget
           ++ (alloAcnt <$> bgtTax)
           ++ (alloAcnt <$> bgtPosttax)
       getSpan = do
-        globalSpan <- askDBState kmBudgetInterval
+        globalSpan <- askDBState csBudgetScope
         case bgtInterval of
           Nothing -> return $ Just globalSpan
           Just bi -> do
@@ -124,7 +122,7 @@ readIncome
       flatTax = concatMap flattenAllo incTaxes
       flatPost = concatMap flattenAllo incPosttax
       sumAllos = sum . fmap faValue
-      -- TODO ensure these are all the "correct" accounts
+      entry0 a c ts = Entry {eAcnt = a, eValue = (), eComment = c, eTags = ts}
       allocate cp gross prevDay day = do
         scaler <- liftExcept $ periodScaler pType' prevDay day
         let precision = cpPrec cp
@@ -138,21 +136,8 @@ readIncome
         let post =
               allocatePost precision aftertaxGross $
                 flatPost ++ concatMap (selectAllos day) intPost
-        -- TODO double or rational here?
+        let src = entry0 srcAcnt "gross income" srcTags
-        let src =
+        let dest = entry0 destAcnt "balance after deductions" destTags
-              Entry
-                { eAcnt = srcAcnt
-                , eValue = ()
-                , eComment = ""
-                , eTags = srcTags
-                }
-        let dest =
-              Entry
-                { eAcnt = destAcnt
-                , eValue = ()
-                , eComment = "balance after deductions"
-                , eTags = destTags
-                }
         let allos = allo2Trans <$> (pre ++ tax ++ post)
         let primary =
               EntrySet
@@ -357,11 +342,13 @@ fromShadow
   => Tx CommitR
   -> ShadowTransfer
   -> m (Maybe ShadowEntrySet)
-fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = do
+fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} =
-  cp <- lookupCurrency stCurrency
+  combineErrorM curRes shaRes $ \cur sha -> do
-  res <- liftExcept $ shadowMatches stMatch tx
+    let es = entryPair stFrom stTo cur stDesc stRatio ()
-  let es = entryPair stFrom stTo (cpID cp) stDesc stRatio ()
+    return $ if not sha then Nothing else Just es
-  return $ if not res then Nothing else Just es
+  where
+    curRes = lookupCurrencyKey stCurrency
+    shaRes = liftExcept $ shadowMatches stMatch tx
 
 shadowMatches :: TransferMatcher -> Tx CommitR -> InsertExcept Bool
 shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDate} = do

lib/Internal/Database.hs

@@ -1,17 +1,15 @@
 module Internal.Database
   ( runDB
+  , readConfigState
   , nukeTables
   , updateHashes
   , updateDBState
   , getDBState
   , tree2Records
   , flattenAcntRoot
+  , indexAcntRoot
   , paths2IDs
   , mkPool
-  , whenHash0
-  , whenHash
-  , whenHash_
-  , eitherHash
   , insertEntry
   , readUpdates
   , insertAll
@@ -29,7 +27,8 @@ import qualified Database.Esqueleto.Experimental as E
 import Database.Esqueleto.Internal.Internal (SqlSelect)
 import Database.Persist.Monad
 import Database.Persist.Sqlite hiding
-  ( delete
+  ( Statement
+  , delete
   , deleteWhere
   , insert
   , insertKey
@@ -43,10 +42,11 @@ import GHC.Err
 import Internal.Types.Main
 import Internal.Utils
 import RIO hiding (LogFunc, isNothing, on, (^.))
-import RIO.List ((\\))
+import qualified RIO.HashSet as HS
 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
@@ -109,6 +109,186 @@ 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
+  -> [Budget]
+  -> [History]
+  -> m ConfigState
+readConfigState c bs hs = do
+  curAcnts <- readCurrentIds AccountRId
+  curTags <- readCurrentIds TagRId
+  curCurs <- readCurrentIds CurrencyRId
+  curPaths <- readCurrentIds AccountPathRId
+  let (acnts2Ins, acntsRem, acnts2Del) = diff newAcnts curAcnts
+  let (pathsIns, _, pathsDel) = diff newPaths curPaths
+  let (curs2Ins, cursRem, curs2Del) = diff newCurs curCurs
+  let (tags2Ins, tagsRem, tags2Del) = diff newTags curTags
+  let amap = makeAcntMap $ acnts2Ins ++ (fst <$> acntsRem)
+  let cmap = currencyMap $ curs2Ins ++ (fst <$> cursRem)
+  let tmap = makeTagMap $ tags2Ins ++ (fst <$> tagsRem)
+  let fromMap f = HS.fromList . fmap (fromIntegral . E.fromSqlKey . f) . M.elems
+  let existing =
+        ExistingConfig (fromMap fst amap) (fromMap id tmap) (fromMap cpID cmap)
+
+  (curBgts, curHistTrs, curHistSts) <- readCurrentCommits
+  (bChanged, hChanged) <- readScopeChanged $ scope c
+  bgt <- makeTxCRUD existing bs curBgts bChanged
+  hTrans <- makeTxCRUD existing ts curHistTrs hChanged
+  hStmt <- makeTxCRUD existing ss curHistSts hChanged
+
+  let bsRes = resolveScope budgetInterval
+  let hsRes = resolveScope statementInterval
+  combineError bsRes hsRes $ \b h ->
+    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 = b
+      , csHistoryScope = h
+      }
+  where
+    (ts, ss) = splitHistory hs
+    diff :: Eq (Key a) => [Entity a] -> [Key a] -> ([Entity a], [(Entity a, Key a)], [Key a])
+    diff = setDiffWith (\a b -> E.entityKey a == b)
+    (newAcnts, newPaths) = indexAcntRoot $ accounts c
+    newTags = tag2Record <$> tags c
+    newCurs = currency2Record <$> currencies c
+    resolveScope f = liftExcept $ resolveDaySpan $ f $ scope c
+
+readScopeChanged :: (MonadInsertError m, MonadSqlQuery m) => TemporalScope -> m (Bool, Bool)
+readScopeChanged s = do
+  rs <- dumpTbl
+  case rs of
+    [] -> return (True, True)
+    [r] -> do
+      let (ConfigStateR hsh bsh) = E.entityVal r
+      return
+        ( hashScope budgetInterval == bsh
+        , hashScope statementInterval == hsh
+        )
+    _ -> throwError undefined
+  where
+    hashScope f = hash $ f s
+
+makeTxCRUD
+  :: (MonadInsertError m, MonadSqlQuery m, Hashable a)
+  => ExistingConfig
+  -> [a]
+  -> [Int]
+  -> Bool
+  -> m
+      ( CRUDOps
+          [a]
+          [ReadEntry]
+          [Either TotalUpdateEntrySet FullUpdateEntrySet]
+          DeleteTxs
+      )
+makeTxCRUD existing newThings curThings scopeChanged = do
+  let (toDelHashes, overlap, toIns) = setDiffWith go 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
+  (toInsRetry, noRetry) <- readInvalidIds existing overlap
+  let toDelAllHashes = toDelHashes ++ (fst <$> toInsRetry)
+  let toInsAll = (snd <$> toInsRetry) ++ toIns
+  -- 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
+  where
+    go a b = hash b == a
+
+readTxIds :: MonadSqlQuery m => [Int] -> 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 tagDesc
+
+currency2Record :: Currency -> Entity CurrencyR
+currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
+  Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision)
+
+readCurrentIds :: PersistEntity a => MonadSqlQuery m => EntityField a (Key a) -> m [Key a]
+readCurrentIds f = fmap (E.unValue <$>) $ selectE $ do
+  rs <- E.from E.table
+  return (rs ^. f)
+
+readCurrentCommits :: MonadSqlQuery m => m ([Int], [Int], [Int])
+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)
+            CTTransfer -> (bs, y : ts, hs)
+            CTHistory -> (bs, ts, y : hs)
+
 hashConfig :: [Budget] -> [History] -> [Int]
 hashConfig bs hs = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
   where
@@ -116,22 +296,28 @@ hashConfig bs hs = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps)
     go (HistTransfer x) = Left x
     go (HistStatement x) = Right x
 
-setDiff :: Eq a => [a] -> [a] -> ([a], [a])
+setDiff2 :: Eq a => [a] -> [a] -> ([a], [a])
--- setDiff = setDiff' (==)
+setDiff2 = setDiffWith2 (==)
-setDiff as bs = (as \\ bs, bs \\ as)
 
--- setDiff' :: Eq a => (a -> b -> Bool) -> [a] -> [b] -> ([a], [b])
+-- setDiff :: Eq a => [a] -> [a] -> ([a], [a], [a])
--- setDiff' f = go []
+-- setDiff as bs = let (as', os, bs') = setDiffWith (==) as bs in (as', fst <$> os, bs')
---   where
+
---     go inA [] bs     = (inA, bs)
+-- setDiff as bs = (as \\ bs, bs \\ as)
---     go inA as []     = (as ++ inA, [])
+setDiffWith2 :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [b])
---     go inA (a:as) bs = case inB a bs of
+setDiffWith2 f as bs = let (as', _, bs') = setDiffWith f as bs in (as', bs')
---       Just bs' -> go inA as bs'
+
---       Nothing  -> go (a:inA) as bs
+setDiffWith :: (a -> b -> Bool) -> [a] -> [b] -> ([a], [(a, b)], [b])
---     inB _ [] = Nothing
+setDiffWith f = go [] []
---     inB a (b:bs)
+  where
---       | f a b = Just bs
+    go inA inBoth [] bs = (inA, inBoth, bs)
---       | otherwise = inB a bs
+    go inA inBoth as [] = (as ++ inA, inBoth, [])
+    go inA inBoth (a : as) bs = case inB a bs of
+      Just (b, bs') -> go inA ((a, b) : inBoth) as bs'
+      Nothing -> go (a : inA) inBoth as bs
+    inB _ [] = Nothing
+    inB a (b : bs)
+      | f a b = Just (b, bs)
+      | otherwise = inB a bs
 
 getDBHashes :: MonadSqlQuery m => m [Int]
 getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl
@@ -148,42 +334,38 @@ getConfigHashes :: MonadSqlQuery m => [Budget] -> [History] -> m ([Int], [Int])
 getConfigHashes bs hs = do
   let ch = hashConfig bs hs
   dh <- getDBHashes
-  return $ setDiff dh ch
+  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 :: MonadSqlQuery m => Entity AccountR -> m ()
-deleteAccount e = deleteE $ do
+-- deleteAccount e = deleteE $ do
-  c <- E.from $ E.table @AccountR
+--   c <- E.from $ E.table @AccountR
-  E.where_ (c ^. AccountRId ==. E.val k)
+--   E.where_ (c ^. AccountRId ==. E.val k)
-  where
+--   where
-    k = entityKey e
+--     k = entityKey e
 
-deleteCurrency :: MonadSqlQuery m => Entity CurrencyR -> m ()
+-- deleteCurrency :: MonadSqlQuery m => Entity CurrencyR -> m ()
-deleteCurrency e = deleteE $ do
+-- deleteCurrency e = deleteE $ do
-  c <- E.from $ E.table @CurrencyR
+--   c <- E.from $ E.table @CurrencyR
-  E.where_ (c ^. CurrencyRId ==. E.val k)
+--   E.where_ (c ^. CurrencyRId ==. E.val k)
-  where
+--   where
-    k = entityKey e
+--     k = entityKey e
 
-deleteTag :: MonadSqlQuery m => Entity TagR -> m ()
+-- deleteTag :: MonadSqlQuery m => Entity TagR -> m ()
-deleteTag e = deleteE $ do
+-- deleteTag e = deleteE $ do
-  c <- E.from $ E.table @TagR
+--   c <- E.from $ E.table @TagR
-  E.where_ (c ^. TagRId ==. E.val k)
+--   E.where_ (c ^. TagRId ==. E.val k)
-  where
+--   where
-    k = entityKey e
+--     k = entityKey e
 
--- TODO slip-n-slide code...
+-- -- TODO slip-n-slide code...
-insertFull
+-- insertFull
-  :: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m)
+--   :: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m)
-  => Entity r
+--   => Entity r
-  -> m ()
+--   -> m ()
-insertFull (Entity k v) = insertKey k v
+-- 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 =
@@ -198,40 +380,35 @@ currencyMap =
 toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
 toKey = toSqlKey . fromIntegral . hash
 
-tree2Entity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR
+parentEntity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR
-tree2Entity t parents name des =
+parentEntity t parents name des =
-  Entity (toSqlKey $ fromIntegral h) $
+  Entity (toSqlKey $ fromIntegral h) $ AccountR name p des (accountSign t) False
-    AccountR name (toPath parents) des (accountSign t)
   where
-    p = AcntPath t (reverse (name : parents))
+    p = AcntPath t (name : parents)
     h = hash p
-    toPath = T.intercalate "/" . (atName t :) . reverse
 
-tree2Records
+tree2Records :: AcntType -> AccountTree -> ([Entity AccountR], [Entity AccountPathR])
-  :: AcntType
-  -> AccountTree
-  -> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntType))])
 tree2Records t = go []
   where
     go ps (Placeholder d n cs) =
-      let e = tree2Entity t (fmap snd ps) n d
+      let e = parentEntity t (fmap snd ps) n d
           k = entityKey e
-          (as, aps, ms) = L.unzip3 $ fmap (go ((k, n) : ps)) cs
+          (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, concat ms)
+       in (a0 : concat as, paths ++ concat aps)
     go ps (Account d n) =
-      let e = tree2Entity t (fmap snd ps) n d
+      let e = parentEntity t (fmap snd ps) n d
           k = entityKey e
-       in ( [acnt k n (fmap snd ps) d]
+       in ([acnt k n (fmap snd ps) d], expand k $ fmap fst ps)
-          , expand k $ fmap fst ps
+    acnt k n ps desc = Entity k $ AccountR n (AcntPath t (n : ps)) desc sign True
-          , [(AcntPath t $ reverse $ n : fmap snd ps, (k, t))]
+    expand h0 hs = (\(h, d) -> accountPathRecord h h0 d) <$> zip (h0 : hs) [0 ..]
-          )
-    toPath = T.intercalate "/" . (atName t :) . reverse
-    acnt k n ps desc = Entity k $ AccountR n (toPath ps) desc sign
-    expand h0 hs = (\(h, d) -> AccountPathR h h0 d) <$> zip (h0 : hs) [0 ..]
     sign = accountSign t
 
+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
@@ -290,14 +467,18 @@ flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arE
     ++ ((AssetT,) <$> arAssets)
     ++ ((EquityT,) <$> arEquity)
 
-indexAcntRoot :: AccountRoot -> ([Entity AccountR], [AccountPathR], AccountMap)
+makeAcntMap :: [Entity AccountR] -> AccountMap
-indexAcntRoot r =
+makeAcntMap =
-  ( concat ars
+  M.fromList
-  , concat aprs
+    . paths2IDs
-  , M.fromList $ paths2IDs $ concat ms
+    . fmap go
-  )
+    . filter (accountRLeaf . snd)
+    . fmap (\e -> (E.entityKey e, E.entityVal e))
   where
-    (ars, aprs, ms) = L.unzip3 $ uncurry tree2Records <$> flattenAcntRoot r
+    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
 
 getDBState
   :: (MonadInsertError m, MonadSqlQuery m)
@@ -310,7 +491,7 @@ getDBState c bs hs = do
   combineError bi si $ \b s ->
     ( DBState
         { kmCurrency = currencyMap cs
-        , kmAccount = am
+        , kmAccount = undefined
         , kmBudgetInterval = b
         , kmStatementInterval = s
         , kmTag = tagMap ts
@@ -319,7 +500,7 @@ getDBState c bs hs = do
     , DBUpdates
         { duOldCommits = del
         , duNewTagIds = ts
-        , duNewAcntPaths = paths
+        , duNewAcntPaths = undefined
         , duNewAcntIds = acnts
         , duNewCurrencyIds = cs
         }
@@ -327,7 +508,7 @@ getDBState c bs hs = do
   where
     bi = liftExcept $ resolveDaySpan $ budgetInterval $ scope c
     si = liftExcept $ resolveDaySpan $ statementInterval $ scope c
-    (acnts, paths, am) = indexAcntRoot $ accounts c
+    (acnts, _) = indexAcntRoot $ accounts c
     cs = currency2Record <$> currencies c
     ts = toRecord <$> tags c
     toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
@@ -336,35 +517,61 @@ getDBState c bs hs = do
 updateHashes :: (MonadSqlQuery m) => DBUpdates -> m ()
 updateHashes DBUpdates {duOldCommits} = nukeDBHashes duOldCommits
 
-updateTags :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
+-- updateTags :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
-updateTags DBUpdates {duNewTagIds} = do
+-- updateTags DBUpdates {duNewTagIds} = do
-  tags' <- selectE $ E.from $ E.table @TagR
+--   tags' <- selectE $ E.from $ E.table @TagR
-  let (toIns, toDel) = setDiff duNewTagIds tags'
+--   let (toIns, toDel) = setDiff2 duNewTagIds tags'
-  mapM_ deleteTag toDel
+--   mapM_ deleteTag toDel
-  mapM_ insertFull toIns
+--   mapM_ insertFull toIns
 
-updateAccounts :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
+-- updateAccounts :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
-updateAccounts DBUpdates {duNewAcntIds, duNewAcntPaths} = do
+-- updateAccounts DBUpdates {duNewAcntIds, duNewAcntPaths} = do
-  acnts' <- dumpTbl
+--   acnts' <- dumpTbl
-  let (toIns, toDel) = setDiff duNewAcntIds acnts'
+--   let (toIns, toDel) = setDiff2 duNewAcntIds acnts'
-  deleteWhere ([] :: [Filter AccountPathR])
+--   deleteWhere ([] :: [Filter AccountPathR])
-  mapM_ deleteAccount toDel
+--   mapM_ deleteAccount toDel
-  mapM_ insertFull toIns
+--   mapM_ insertFull toIns
-  mapM_ insert duNewAcntPaths
+--   mapM_ insert duNewAcntPaths
 
-updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
+-- updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
-updateCurrencies DBUpdates {duNewCurrencyIds} = do
+-- updateCurrencies DBUpdates {duNewCurrencyIds} = do
-  curs' <- selectE $ E.from $ E.table @CurrencyR
+--   curs' <- selectE $ E.from $ E.table @CurrencyR
-  let (toIns, toDel) = setDiff duNewCurrencyIds curs'
+--   let (toIns, toDel) = setDiff2 duNewCurrencyIds curs'
-  mapM_ deleteCurrency toDel
+--   mapM_ deleteCurrency toDel
-  mapM_ insertFull toIns
+--   mapM_ insertFull toIns
 
-updateDBState :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
+updateCD
-updateDBState u = do
+  :: ( MonadSqlQuery m
-  updateHashes u
+     , PersistRecordBackend a SqlBackend
-  updateTags u
+     , PersistRecordBackend b SqlBackend
-  updateAccounts u
+     )
-  updateCurrencies u
+  => 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)
+
+-- updateHashes u
+-- updateTags u
+-- updateAccounts u
+-- updateCurrencies u
 
 deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
 deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
@@ -372,54 +579,95 @@ 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
+deleteKeyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => Key a -> m ()
-  :: (Hashable a, MonadFinance m, MonadSqlQuery m)
+deleteKeyE q = unsafeLiftSql "esqueleto-select" (E.deleteKey q)
-  => 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
+insertEntityManyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => [Entity a] -> m ()
-  :: (Hashable a, MonadFinance m)
+insertEntityManyE q = unsafeLiftSql "esqueleto-select" (E.insertEntityMany q)
-  => 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
+-- whenHash
-  :: (Hashable a, MonadFinance m)
+--   :: (Hashable a, MonadFinance m, MonadSqlQuery m)
-  => ConfigType
+--   => ConfigType
-  -> a
+--   -> a
-  -> (CommitR -> m b)
+--   -> b
-  -> (CommitR -> m c)
+--   -> (CommitRId -> m b)
-  -> m (Either b c)
+--   -> m b
-eitherHash t o f g = do
+-- whenHash t o def f = do
-  let h = hash o
+--   let h = hash o
-  let c = CommitR h t
+--   hs <- askDBState kmNewCommits
-  hs <- askDBState kmNewCommits
+--   if h `elem` hs then f =<< insert (CommitR h t) else return def
-  if h `elem` hs then Right <$> g c else Left <$> f c
 
-whenHash_
+-- whenHash0
-  :: (Hashable a, MonadFinance m)
+--   :: (Hashable a, MonadFinance m)
-  => ConfigType
+--   => ConfigType
-  -> a
+--   -> a
-  -> m b
+--   -> b
-  -> m (Maybe (CommitR, b))
+--   -> (CommitR -> m b)
-whenHash_ t o f = do
+--   -> m b
-  let h = hash o
+-- whenHash0 t o def f = do
-  let c = CommitR h t
+--   let h = hash o
-  hs <- askDBState kmNewCommits
+--   hs <- askDBState kmNewCommits
-  if h `elem` hs then Just . (c,) <$> f else return Nothing
+--   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, a)], [Int])
+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.innerJoin` E.table
+        `E.on` (\(_ :& _ :& _ :& e :& r) -> 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 (\(i, c, _, _) -> (i, c)) rs
+  let as = go ecAccounts (\(i, _, a, _) -> (i, a)) rs
+  let ts = go ecTags (\(i, _, _, t) -> (i, t)) rs
+  let valid = (cs `HS.intersection` as) `HS.intersection` ts
+  return $ second (fst <$>) $ L.partition ((`HS.member` valid) . fst) xs
+  where
+    go existing f =
+      HS.fromList
+        . fmap (E.unValue . fst)
+        . L.filter (all (`HS.member` existing) . fmap (fromIntegral . E.fromSqlKey . E.unValue) . snd)
+        . groupKey id
+        . fmap f
 
 readUpdates
   :: (MonadInsertError m, MonadSqlQuery m)
@@ -457,10 +705,12 @@ readUpdates hashes = do
       )
   let (toUpdate, toRead) = L.partition (E.unValue . fst) xs
   toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _, _) -> i) (snd <$> toUpdate)
-  return (makeRE . snd <$> toRead, 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) $
@@ -477,7 +727,7 @@ readUpdates hashes = do
               Left $
                 UpdateEntrySet
                   { utDate = E.unValue day
-                  , utCurrency = E.unValue curID
+                  , utCurrency = cur
                   , utFrom0 = x
                   , utTo0 = to0
                   , utFromRO = fromRO
@@ -492,7 +742,7 @@ readUpdates hashes = do
               Right $
                 UpdateEntrySet
                   { utDate = E.unValue day
-                  , utCurrency = E.unValue curID
+                  , utCurrency = cur
                   , utFrom0 = x
                   , utTo0 = to0
                   , utFromRO = fromRO
@@ -504,7 +754,7 @@ readUpdates hashes = do
                   , utPriority = E.unValue pri
                   }
         _ -> throwError undefined
-    makeRE ((_, day, name, pri, (curID, prec)), entry) =
+    makeRE ((_, day, name, pri, (curID, prec)), entry) = do
       let e = entityVal entry
        in ReadEntry
             { reDate = E.unValue day

lib/Internal/History.hs

@@ -9,8 +9,8 @@ import Control.Monad.Except
 import Data.Csv
 import Data.Decimal
 import Data.Foldable
+import Data.Hashable
 import GHC.Real
-import Internal.Database
 import Internal.Types.Main
 import Internal.Utils
 import RIO hiding (to)
@@ -39,10 +39,12 @@ splitHistory = partitionEithers . fmap go
 readHistTransfer
   :: (MonadInsertError m, MonadFinance m)
   => PairedTransfer
-  -> m (Either CommitR [Tx CommitR])
+  -> m [Tx CommitR]
-readHistTransfer ht = eitherHash CTManual ht return $ \c -> do
+readHistTransfer ht = do
-  bounds <- askDBState kmStatementInterval
+  bounds <- askDBState csHistoryScope
   expandTransfer c historyName bounds ht
+  where
+    c = CommitR (hash ht) CTTransfer
 
 --------------------------------------------------------------------------------
 -- Statements
@@ -51,11 +53,13 @@ readHistStmt
   :: (MonadUnliftIO m, MonadFinance m)
   => FilePath
   -> Statement
-  -> m (Either CommitR [Tx CommitR])
+  -> m [Tx CommitR]
-readHistStmt root i = eitherHash CTImport i return $ \c -> do
+readHistStmt root i = do
   bs <- readImport root i
-  bounds <- askDBState kmStatementInterval
+  bounds <- askDBState csHistoryScope
   return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
+  where
+    c = CommitR (hash i) CTTransfer
 
 -- TODO this probably won't scale well (pipes?)
 readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
@@ -78,7 +82,7 @@ readImport_
   -> m [TxRecord]
 readImport_ n delim tns p = do
   res <- tryIO $ BL.readFile p
-  bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
+  bs <- fromEither $ first (InsertException . (: []) . InsertIOError . tshow) res
   case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
     Left m -> throwIO $ InsertException [ParseError $ T.pack m]
     Right (_, v) -> return $ catMaybes $ V.toList v
@@ -313,7 +317,7 @@ toTx
         }
     where
       curRes = do
-        m <- askDBState kmCurrency
+        m <- askDBState csCurrencyMap
         cur <- liftInner $ resolveCurrency m r tgCurrency
         let prec = cpPrec cur
         let fromRes = liftInner $ resolveHalfEntry resolveFromValue prec r () tgFrom
@@ -327,7 +331,7 @@ resolveSubGetter
   -> TxSubGetter
   -> InsertExceptT m SecondayEntrySet
 resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
-  m <- askDBState kmCurrency
+  m <- askDBState csCurrencyMap
   cur <- liftInner $ resolveCurrency m r tsgCurrency
   let prec = cpPrec cur
   let toRes = resolveHalfEntry resolveToValue prec r () tsgTo

lib/Internal/Types/Database.hs

@@ -14,6 +14,7 @@ import RIO
 import qualified RIO.Text as T
 import RIO.Time
 
+-- TODO use newtypes for all the different numbers so they don't get mixed up
 share
   [mkPersist sqlSettings, mkMigrate "migrateAll"]
   [persistLowerCase|
@@ -21,20 +22,24 @@ CommitR sql=commits
     hash Int
     type ConfigType
     deriving Show Eq Ord
+ConfigStateR sql=config_state
+    historyScopeHash Int
+    budgetScopeHash Int
 CurrencyR sql=currencies
-    symbol T.Text
+    symbol CurID
     fullname T.Text
     precision Int
     deriving Show Eq
 TagR sql=tags
-    symbol T.Text
+    symbol TagID
     fullname T.Text
     deriving Show Eq
 AccountR sql=accounts
     name T.Text
-    fullpath T.Text
+    fullpath AcntPath
     desc T.Text
     sign AcntSign
+    leaf Bool
     deriving Show Eq
 AccountPathR sql=account_paths
     parent AccountRId OnDeleteCascade
@@ -70,7 +75,7 @@ TagRelationR sql=tag_relations
     deriving Show Eq
 |]
 
-data ConfigType = CTBudget | CTManual | CTImport
+data ConfigType = CTBudget | CTTransfer | CTHistory
   deriving (Eq, Show, Read, Enum, Ord)
 
 instance PersistFieldSql ConfigType where
@@ -97,3 +102,38 @@ instance PersistField AcntSign where
   fromPersistValue (PersistInt64 (-1)) = Right Credit
   fromPersistValue (PersistInt64 v) = Left $ "could not convert to account sign: " <> tshow v
   fromPersistValue _ = Left "not an Int64"
+
+data AcntType
+  = AssetT
+  | EquityT
+  | ExpenseT
+  | IncomeT
+  | LiabilityT
+  deriving (Show, Eq, Ord, Hashable, Generic, Read)
+
+atName :: AcntType -> T.Text
+atName AssetT = "asset"
+atName EquityT = "equity"
+atName ExpenseT = "expense"
+atName IncomeT = "income"
+atName LiabilityT = "liability"
+
+data AcntPath = AcntPath
+  { apType :: !AcntType
+  , apChildren :: ![T.Text]
+  }
+  deriving (Eq, Ord, Show, Hashable, Generic, Read)
+
+instance PersistFieldSql AcntPath where
+  sqlType _ = SqlString
+
+instance PersistField AcntPath where
+  toPersistValue (AcntPath t cs) =
+    PersistText $ T.intercalate "/" $ (atName t :) $ reverse cs
+
+  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
+      _ -> Left "could not get account type"
+  fromPersistValue _ = Left "not a string"

lib/Internal/Types/Dhall.hs

@@ -371,7 +371,7 @@ data AccountRoot_ a = AccountRoot_
   , arIncome :: ![a]
   , arLiabilities :: ![a]
   }
-  deriving (Generic)
+  deriving (Generic, Hashable)
 
 type AccountRootF = AccountRoot_ (Fix AccountTreeF)
 

lib/Internal/Types/Main.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE UndecidableInstances #-}
 
@@ -17,7 +16,6 @@ import Database.Persist.Sql hiding (Desc, In, Statement)
 import Dhall hiding (embed, maybe)
 import Internal.Types.Database
 import Internal.Types.Dhall
-import Language.Haskell.TH.Syntax (Lift)
 import RIO
 import qualified RIO.Map as M
 import qualified RIO.NonEmpty as NE
@@ -35,6 +33,36 @@ data ConfigHashes = ConfigHashes
   , chImport :: ![Int]
   }
 
+data DeleteTxs = DeleteTxs
+  { dtTxs :: ![TransactionRId]
+  , dtEntrySets :: ![EntrySetRId]
+  , dtEntries :: ![EntryRId]
+  , dtTagRelations :: ![TagRelationRId]
+  }
+
+type CDOps c d = CRUDOps [c] () () [d]
+
+data ConfigState = ConfigState
+  { csCurrencies :: !(CDOps (Entity CurrencyR) CurrencyRId)
+  , csAccounts :: !(CDOps (Entity AccountR) AccountRId)
+  , csPaths :: !(CDOps (Entity AccountPathR) AccountPathRId)
+  , csTags :: !(CDOps (Entity TagR) TagRId)
+  , csBudgets :: !(CRUDOps [Budget] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
+  , csHistTrans :: !(CRUDOps [PairedTransfer] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
+  , csHistStmts :: !(CRUDOps [Statement] [ReadEntry] [Either TotalUpdateEntrySet FullUpdateEntrySet] DeleteTxs)
+  , csAccountMap :: !AccountMap
+  , csCurrencyMap :: !CurrencyMap
+  , csTagMap :: !TagMap
+  , csBudgetScope :: !DaySpan
+  , csHistoryScope :: !DaySpan
+  }
+
+data ExistingConfig = ExistingConfig
+  { ecAccounts :: !(HashSet Int)
+  , ecTags :: !(HashSet Int)
+  , ecCurrencies :: !(HashSet Int)
+  }
+
 type AccountMap = M.Map AcntID (AccountRId, AcntType)
 
 data CurrencyPrec = CurrencyPrec {cpID :: !CurrencyRId, cpPrec :: !Precision}
@@ -44,6 +72,23 @@ type CurrencyMap = M.Map CurID CurrencyPrec
 
 type TagMap = M.Map TagID TagRId
 
+data CRUDOps c r u d = CRUDOps
+  { coCreate :: !c
+  , coRead :: !r
+  , coUpdate :: !u
+  , coDelete :: !d
+  }
+
+data DBState_ = DBState_
+  { dbsCurrencyMap :: !CurrencyMap
+  , dbsAccountMap :: !AccountMap
+  , dbsTagMap :: !TagMap
+  , dbsBudgetInterval :: !DaySpan
+  , dbsHistoryInterval :: !DaySpan
+  , dbsNewCommits :: ![Int]
+  }
+  deriving (Show)
+
 data DBState = DBState
   { kmCurrency :: !CurrencyMap
   , kmAccount :: !AccountMap
@@ -63,8 +108,6 @@ data DBUpdates = DBUpdates
   }
   deriving (Show)
 
-type CurrencyM = Reader CurrencyMap
-
 data DBDeferred
   = DBEntryLinked Natural Double
   | DBEntryBalance Decimal
@@ -138,35 +181,14 @@ data EntryBin
 
 type TreeR = Tree ([T.Text], AccountRId)
 
-type MonadFinance = MonadReader DBState
+type MonadFinance = MonadReader ConfigState
 
-askDBState :: MonadFinance m => (DBState -> a) -> m a
+askDBState :: MonadFinance m => (ConfigState -> a) -> m a
 askDBState = asks
 
 -------------------------------------------------------------------------------
 -- misc
 
-data AcntType
-  = AssetT
-  | EquityT
-  | ExpenseT
-  | IncomeT
-  | LiabilityT
-  deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall)
-
-atName :: AcntType -> T.Text
-atName AssetT = "asset"
-atName EquityT = "equity"
-atName ExpenseT = "expense"
-atName IncomeT = "income"
-atName LiabilityT = "liability"
-
-data AcntPath = AcntPath
-  { apType :: !AcntType
-  , apChildren :: ![T.Text]
-  }
-  deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall)
-
 data TxRecord = TxRecord
   { trDate :: !Day
   , trAmount :: !Decimal
@@ -178,19 +200,8 @@ data TxRecord = TxRecord
 
 type DaySpan = (Day, Natural)
 
-data Keyed a = Keyed
-  { kKey :: !Int64
-  , kVal :: !a
-  }
-  deriving (Eq, Show, Functor)
-
 data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
 
--- TODO debit should be negative
-sign2Int :: AcntSign -> Int
-sign2Int Debit = 1
-sign2Int Credit = 1
-
 accountSign :: AcntType -> AcntSign
 accountSign AssetT = Debit
 accountSign ExpenseT = Debit

lib/Internal/Utils.hs

@@ -152,7 +152,7 @@ askDays
   -> Maybe Interval
   -> m [Day]
 askDays dp i = do
-  globalSpan <- askDBState kmBudgetInterval
+  globalSpan <- askDBState csBudgetScope
   case i of
     Just i' -> do
       localSpan <- liftExcept $ resolveDaySpan i'
@@ -419,14 +419,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
 
--- roundPrecision :: Natural -> Double -> Rational
--- roundPrecision n = (% p) . round . (* fromIntegral p) . toRational
---   where
---     p = 10 ^ n
-
--- roundPrecisionCur :: CurrencyPrec -> Double -> Rational
--- roundPrecisionCur (CurrencyPrec _ n) = roundPrecision n
-
 acntPath2Text :: AcntPath -> T.Text
 acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
 
@@ -638,7 +630,7 @@ uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
 uncurry3 f (a, b, c) = f a b c
 
 lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntType)
-lookupAccount = lookupFinance AcntField kmAccount
+lookupAccount = lookupFinance AcntField csAccountMap
 
 lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId
 lookupAccountKey = fmap fst . lookupAccount
@@ -647,7 +639,7 @@ lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntTyp
 lookupAccountType = fmap snd . lookupAccount
 
 lookupCurrency :: (MonadInsertError m, MonadFinance m) => CurID -> m CurrencyPrec
-lookupCurrency = lookupFinance CurField kmCurrency
+lookupCurrency = lookupFinance CurField csCurrencyMap
 
 lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId
 lookupCurrencyKey = fmap cpID . lookupCurrency
@@ -656,12 +648,12 @@ lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Precis
 lookupCurrencyPrec = fmap cpPrec . lookupCurrency
 
 lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
-lookupTag = lookupFinance TagField kmTag
+lookupTag = lookupFinance TagField csTagMap
 
 lookupFinance
   :: (MonadInsertError m, MonadFinance m)
   => EntryIDType
-  -> (DBState -> M.Map T.Text a)
+  -> (ConfigState -> M.Map T.Text a)
   -> T.Text
   -> m a
 lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f
@@ -865,7 +857,7 @@ balancePrimaryEntrySet
       combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $
         \(f0', fs') (t0', ts') -> do
           let balFrom = fmap liftInnerS . balanceDeferred
-          fs'' <- doEntries balFrom bc esTotalValue f0' fs'
+          fs'' <- balanceTotalEntrySet balFrom bc esTotalValue f0' fs'
           balanceFinal bc (-esTotalValue) fs'' t0' ts'
 
 balanceSecondaryEntrySet
@@ -904,7 +896,7 @@ balanceFinal
 balanceFinal k@(curID, _) tot fs t0 ts = do
   let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs
   let balTo = balanceLinked fv
-  ts' <- doEntries balTo k tot t0 ts
+  ts' <- balanceTotalEntrySet balTo k tot t0 ts
   return $
     InsertEntrySet
       { iesCurrency = curID
@@ -912,7 +904,7 @@ balanceFinal k@(curID, _) tot fs t0 ts = do
       , iesToEntries = ts'
       }
 
-doEntries
+balanceTotalEntrySet
   :: (MonadInsertError m)
   => (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe DBDeferred))
   -> BCKey
@@ -920,7 +912,7 @@ doEntries
   -> Entry AccountRId () TagRId
   -> [Entry AccountRId v TagRId]
   -> StateT EntryBals m (NonEmpty InsertEntry)
-doEntries f k tot e@Entry {eAcnt = acntID} es = do
+balanceTotalEntrySet f k tot e@Entry {eAcnt = acntID} es = do
   es' <- mapErrors (balanceEntry f k) es
   let e0val = tot - entrySum es'
   -- TODO not dry