WIP split IO actions into stages

app/Main.hs

@@ -2,8 +2,12 @@
 
 module Main (main) where
 
+import Control.Monad.Except
+import Control.Monad.IO.Rerunnable
+import Control.Monad.Logger
 import Control.Monad.Reader
 import qualified Data.Text.IO as TI
+import Database.Persist.Monad
 import Internal.Config
 import Internal.Database.Ops
 import Internal.Insert
@@ -158,11 +162,28 @@ runDumpAccountKeys c = do
 runSync :: FilePath -> IO ()
 runSync c = do
   config <- readConfig c
-  handle err $ runDB (sqlConfig config) $ do
+  let (hTs, hSs) = splitHistory $ statements config
-    let bgtRes = liftIOExceptT $ mapErrors insertBudget $ budget config
+  pool <- runNoLoggingT $ mkPool $ sqlConfig config
-    let histRes = mapErrorsIO insertStatement $ statements config
+  handle err $ do
-    s <- fmap (\f -> f $ takeDirectory c) $ liftIOExceptT $ getDBState config
+    -- _ <- askLoggerIO
-    flip runReaderT s $ combineErrorIO2 bgtRes histRes $ \_ _ -> ()
+
+    -- get the current DB state
+    s <- runSqlQueryT pool $ do
+      runMigration migrateAll
+      fmap (\f -> f $ takeDirectory c) $ liftIOExceptT $ getDBState config
+
+    -- read desired statements from disk
+    bSs <- flip runReaderT s $ catMaybes <$> mapM readHistStmt hSs
+
+    -- update the DB
+    runSqlQueryT pool $ withTransaction $ flip runReaderT s $ do
+      let hTransRes = mapErrors insertHistTransfer hTs
+      let bgtRes = mapErrors insertBudget $ budget config
+      updateDBState -- TODO this will only work if foreign keys are deferred
+      res <- runExceptT $ do
+        mapM_ (uncurry insertHistStmt) bSs
+        combineError hTransRes bgtRes $ \_ _ -> ()
+      rerunnableIO $ fromEither res
   where
     err (InsertException es) = do
       liftIO $ mapM_ TI.putStrLn $ concatMap showError es

lib/Internal/Database/Ops.hs

@@ -2,10 +2,12 @@ module Internal.Database.Ops
   ( runDB
   , nukeTables
   , updateHashes
+  , updateDBState
   , getDBState
   , tree2Records
   , flattenAcntRoot
   , paths2IDs
+  , mkPool
   )
 where
 
@@ -134,12 +136,6 @@ getConfigHashes c = do
   dh <- getDBHashes
   return $ setDiff dh ch
 
-updateHashes :: MonadSqlQuery m => Config -> m [Int]
-updateHashes c = do
-  (del, new) <- getConfigHashes c
-  nukeDBHashes del
-  return new
-
 dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
 dumpTbl = selectE $ E.from E.table
 
@@ -164,18 +160,6 @@ deleteTag e = deleteE $ do
   where
     k = entityKey e
 
-updateAccounts :: MonadSqlQuery m => AccountRoot -> m AccountMap
-updateAccounts ar = do
-  let (acnts, paths, acntMap) = indexAcntRoot ar
-  acnts' <- dumpTbl
-  let (toIns, toDel) = setDiff acnts acnts'
-  deleteWhere ([] :: [Filter AccountPathR])
-  mapM_ deleteAccount toDel
-  -- liftIO $ mapM_ print toDel
-  mapM_ insertFull toIns
-  mapM_ insert paths
-  return acntMap
-
 -- TODO slip-n-slide code...
 insertFull
   :: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m)
@@ -183,15 +167,6 @@ insertFull
   -> m ()
 insertFull (Entity k v) = insertKey k v
 
-updateCurrencies :: MonadSqlQuery m => [Currency] -> m CurrencyMap
-updateCurrencies cs = do
-  let curs = fmap currency2Record cs
-  curs' <- selectE $ E.from $ E.table @CurrencyR
-  let (toIns, toDel) = setDiff curs curs'
-  mapM_ deleteCurrency toDel
-  mapM_ insertFull toIns
-  return $ currencyMap curs
-
 currency2Record :: Currency -> Entity CurrencyR
 currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
   Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision)
@@ -206,18 +181,6 @@ currencyMap =
           )
       )
 
-updateTags :: MonadSqlQuery m => [Tag] -> m TagMap
-updateTags cs = do
-  let tags = fmap toRecord cs
-  tags' <- selectE $ E.from $ E.table @TagR
-  let (toIns, toDel) = setDiff tags tags'
-  mapM_ deleteTag toDel
-  mapM_ insertFull toIns
-  return $ tagMap tags
-  where
-    toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
-    tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
-
 toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
 toKey = toSqlKey . fromIntegral . hash
 
@@ -327,25 +290,74 @@ getDBState
   => Config
   -> m (FilePath -> DBState)
 getDBState c = do
-  am <- updateAccounts $ accounts c
+  (del, new) <- getConfigHashes c
-  cm <- updateCurrencies $ currencies c
-  ts <- updateTags $ tags c
-  hs <- updateHashes c
   -- TODO not sure how I feel about this, probably will change this struct alot
   -- in the future so whatever...for now
   combineError bi si $ \b s f ->
+    -- TODO this can be cleaned up, half of it is meant to be queried when
+    -- determining how to insert budgets/history and the rest is just
+    -- holdover data to delete upon successful insertion
     DBState
-      { kmCurrency = cm
+      { kmCurrency = currencyMap cs
       , kmAccount = am
       , kmBudgetInterval = b
       , kmStatementInterval = s
-      , kmNewCommits = hs
+      , kmNewCommits = new
+      , kmOldCommits = del
       , kmConfigDir = f
-      , kmTag = ts
+      , kmTag = tagMap ts
+      , kmTagAll = ts
+      , kmAcntPaths = paths
+      , kmAcntsOld = acnts
+      , kmCurrenciesOld = cs
       }
   where
     bi = liftExcept $ resolveBounds $ budgetInterval $ global c
     si = liftExcept $ resolveBounds $ 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 :: (MonadFinance m, MonadSqlQuery m) => m ()
+updateHashes = do
+  old <- askDBState kmOldCommits
+  nukeDBHashes old
+
+updateTags :: (MonadFinance m, MonadSqlQuery m) => m ()
+updateTags = do
+  tags <- askDBState kmTagAll
+  tags' <- selectE $ E.from $ E.table @TagR
+  let (toIns, toDel) = setDiff tags tags'
+  mapM_ deleteTag toDel
+  mapM_ insertFull toIns
+
+updateAccounts :: (MonadFinance m, MonadSqlQuery m) => m ()
+updateAccounts = do
+  acnts <- askDBState kmAcntsOld
+  paths <- askDBState kmAcntPaths
+  acnts' <- dumpTbl
+  let (toIns, toDel) = setDiff acnts acnts'
+  deleteWhere ([] :: [Filter AccountPathR])
+  mapM_ deleteAccount toDel
+  mapM_ insertFull toIns
+  mapM_ insert paths
+
+updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => m ()
+updateCurrencies = do
+  curs <- askDBState kmCurrenciesOld
+  curs' <- selectE $ E.from $ E.table @CurrencyR
+  let (toIns, toDel) = setDiff curs curs'
+  mapM_ deleteCurrency toDel
+  mapM_ insertFull toIns
+
+updateDBState :: (MonadFinance m, MonadSqlQuery m) => m ()
+updateDBState = do
+  updateHashes
+  updateTags
+  updateAccounts
+  updateCurrencies
 
 deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
 deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)

lib/Internal/Insert.hs

@@ -1,6 +1,9 @@
 module Internal.Insert
-  ( insertStatement
+  ( insertBudget
-  , insertBudget
+  , splitHistory
+  , insertHistTransfer
+  , readHistStmt
+  , insertHistStmt
   )
 where
 
@@ -116,7 +119,10 @@ withDates dp f = do
 -- 4. assign shadow transactions (TODO)
 -- 5. insert all transactions
 
-insertBudget :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => Budget -> m ()
+insertBudget
+  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
+  => Budget
+  -> m [UnbalancedTransfer]
 insertBudget
   b@Budget
     { bgtLabel
@@ -127,16 +133,15 @@ insertBudget
     , bgtTax
     , bgtPosttax
     } =
-    whenHash CTBudget b () $ \key -> do
+    whenHash CTBudget b [] $ \key -> do
       intAllos <- combineError3 pre_ tax_ post_ (,,)
-      let res1 = combineErrors $ fmap (insertIncome key bgtLabel intAllos) bgtIncomes
+      let res1 = mapErrors (insertIncome key bgtLabel intAllos) bgtIncomes
       let res2 = expandTransfers key bgtLabel bgtTransfers
       txs <- combineError (concat <$> res1) res2 (++)
       m <- askDBState kmCurrency
       shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
-      let bals = balanceTransfers $ txs ++ shadow
+      void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow
-      _ <- combineErrors $ fmap insertBudgetTx bals
+      return $ shadow ++ txs
-      return ()
     where
       pre_ = sortAllos bgtPretax
       tax_ = sortAllos bgtTax
@@ -251,11 +256,13 @@ data FlatTransfer v = FlatTransfer
   , cbtMeta :: !BudgetMeta
   , cbtCur :: !BudgetCurrency
   }
+  deriving (Show)
 
 data UnbalancedValue = UnbalancedValue
   { cvType :: !BudgetTransferType
   , cvValue :: !Rational
   }
+  deriving (Show)
 
 type UnbalancedTransfer = FlatTransfer UnbalancedValue
 
@@ -529,18 +536,24 @@ checkAcntTypes ts i = go =<< lookupAccountType i
 --------------------------------------------------------------------------------
 -- statements
 
-insertStatement
+splitHistory :: [History] -> ([HistTransfer], [Statement])
-  :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
+splitHistory = partitionEithers . fmap go
-  => History
+  where
-  -> m ()
+    go (HistTransfer x) = Left x
-insertStatement (HistTransfer m) = liftIOExceptT $ insertManual m
+    go (HistStatement x) = Right x
-insertStatement (HistStatement i) = insertImport i
 
-insertManual
+-- insertStatement
+--   :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
+--   => History
+--   -> m ()
+-- insertStatement (HistTransfer m) = liftIOExceptT $ insertManual m
+-- insertStatement (HistStatement i) = insertImport i
+
+insertHistTransfer
   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
   => HistTransfer
   -> m ()
-insertManual
+insertHistTransfer
   m@Transfer
     { transFrom = from
     , transTo = to
@@ -558,17 +571,28 @@ insertManual
             mapM_ (insertTx c) keys
       void $ combineErrors $ fmap go amts
 
-insertImport
+readHistStmt :: (MonadUnliftIO m, MonadFinance m) => Statement -> m (Maybe (CommitR, [KeyTx]))
-  :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
+readHistStmt i = whenHash_ CTImport i $ do
-  => Statement
-  -> m ()
-insertImport i = whenHash CTImport i () $ \c -> do
-  -- TODO this isn't efficient, the whole file will be read and maybe no
-  -- transactions will be desired
   bs <- readImport i
   bounds <- expandBounds <$> askDBState kmStatementInterval
-  keys <- liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs
+  liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs
-  mapM_ (insertTx c) keys
+
+insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m ()
+insertHistStmt c ks = do
+  ck <- insert c
+  mapM_ (insertTx ck) ks
+
+-- insertImport
+--   :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
+--   => Statement
+--   -> m ()
+-- insertImport i = whenHash CTImport i () $ \c -> do
+--   -- TODO this isn't efficient, the whole file will be read and maybe no
+--   -- transactions will be desired
+--   bs <- readImport i
+--   bounds <- expandBounds <$> askDBState kmStatementInterval
+--   keys <- liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs
+--   mapM_ (insertTx c) keys
 
 --------------------------------------------------------------------------------
 -- low-level transaction stuff
@@ -667,7 +691,6 @@ lookupFinance
 lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f
 
 -- TODO this hashes twice (not that it really matters)
--- TODO generalize this (persistent mtl)
 
 whenHash
   :: (Hashable a, MonadFinance m, MonadSqlQuery m)
@@ -680,3 +703,15 @@ 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
+
+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

lib/Internal/Types.hs

@@ -597,7 +597,12 @@ data DBState = DBState
   , kmBudgetInterval :: !Bounds
   , kmStatementInterval :: !Bounds
   , kmNewCommits :: ![Int]
+  , kmOldCommits :: ![Int]
   , kmConfigDir :: !FilePath
+  , kmTagAll :: ![Entity TagR]
+  , kmAcntPaths :: ![AccountPathR]
+  , kmAcntsOld :: ![Entity AccountR]
+  , kmCurrenciesOld :: ![Entity CurrencyR]
   }
 
 type CurrencyM = Reader CurrencyMap