REF split db state with stuff to be updated later

app/Main.hs

@@ -169,23 +169,26 @@ runSync c = do
     -- _ <- askLoggerIO
 
     -- get the current DB state
-    s <- runSqlQueryT pool $ do
+    (state, updates) <- runSqlQueryT pool $ do
       runMigration migrateAll
-      fmap (\f -> f $ takeDirectory c) $ liftIOExceptT $ getDBState config
+      liftIOExceptT $ getDBState config
 
     -- read desired statements from disk
-    bSs <- flip runReaderT s $ catMaybes <$> mapErrorsIO readHistStmt hSs
+    bSs <-
+      flip runReaderT state $
+        catMaybes <$> mapErrorsIO (readHistStmt root) hSs
 
     -- update the DB
-    runSqlQueryT pool $ withTransaction $ flip runReaderT s $ do
+    runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
       let hTransRes = mapErrors insertHistTransfer hTs
       let bgtRes = mapErrors insertBudget $ budget config
-      updateDBState -- TODO this will only work if foreign keys are deferred
+      updateDBState updates -- TODO this will only work if foreign keys are deferred
       res <- runExceptT $ do
         mapM_ (uncurry insertHistStmt) bSs
         combineError hTransRes bgtRes $ \_ _ -> ()
       rerunnableIO $ fromEither res
   where
+    root = takeDirectory c
     err (InsertException es) = do
       liftIO $ mapM_ TI.putStrLn $ concatMap showError es
       exitFailure

lib/Internal/Database.hs

@@ -0,0 +1,416 @@
+module Internal.Database
+  ( runDB
+  , nukeTables
+  , updateHashes
+  , updateDBState
+  , getDBState
+  , tree2Records
+  , flattenAcntRoot
+  , paths2IDs
+  , mkPool
+  , whenHash
+  , whenHash_
+  , insertEntry
+  , resolveEntry
+  )
+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
+  , (==.)
+  , (||.)
+  )
+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 N
+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
+          , (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) = N.reverse $ atName t :| ns
+
+-- none of these errors should fire assuming that input is sorted and unique
+trimNames :: [N.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 = N.take (i + 1)
+    err msg = errorWithoutStackTrace $ "Import.Database.Ops.hs: " ++ msg
+
+(!?) :: N.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
+
+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
+
+insertEntry :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId
+insertEntry t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
+  k <- insert $ EntryR t eCurrency eAcnt eComment eValue
+  mapM_ (insert_ . TagRelationR k) eTags
+  return k
+
+resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry
+resolveEntry s@Entry {eAcnt, eCurrency, eValue, eTags} = do
+  let aRes = lookupAccountKey eAcnt
+  let cRes = lookupCurrencyKey eCurrency
+  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
+        { eAcnt = aid
+        , eCurrency = cid
+        , eValue = eValue * fromIntegral (sign2Int sign)
+        , eTags = tags
+        }

lib/Internal/History.hs

@@ -49,9 +49,13 @@ insertHistTransfer
             mapM_ (insertTx c) keys
       void $ combineErrors $ fmap go amts
 
-readHistStmt :: (MonadUnliftIO m, MonadFinance m) => Statement -> m (Maybe (CommitR, [KeyTx]))
+readHistStmt
-readHistStmt i = whenHash_ CTImport i $ do
+  :: (MonadUnliftIO m, MonadFinance m)
-  bs <- readImport i
+  => FilePath
+  -> Statement
+  -> m (Maybe (CommitR, [KeyTx]))
+readHistStmt root i = whenHash_ CTImport i $ do
+  bs <- readImport root i
   bounds <- askDBState kmStatementInterval
   liftIOExceptT $ mapErrors resolveTx $ filter (inDaySpan bounds . txDate) bs
 
@@ -105,29 +109,30 @@ insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
 -- Statements
 
 -- TODO this probably won't scale well (pipes?)
-readImport :: (MonadUnliftIO m, MonadFinance m) => Statement -> m [BalTx]
+readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [BalTx]
-readImport Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
+readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
   let ores = compileOptions stmtTxOpts
   let cres = combineErrors $ compileMatch <$> stmtParsers
   (compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
   let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
-  records <- L.sort . concat <$> mapErrorsIO readStmt stmtPaths
+  records <- L.sort . concat <$> mapErrorsIO readStmt paths
   m <- askDBState kmCurrency
   fromEither $
     flip runReader m $
       runExceptT $
         matchRecords compiledMatches records
+  where
+    paths = (root </>) <$> stmtPaths
 
 readImport_
-  :: (MonadUnliftIO m, MonadFinance m)
+  :: MonadUnliftIO m
   => Natural
   -> Word
   -> TxOptsRe
   -> FilePath
   -> m [TxRecord]
 readImport_ n delim tns p = do
-  dir <- askDBState kmConfigDir
+  res <- tryIO $ BL.readFile p
-  res <- tryIO $ BL.readFile $ dir </> p
   bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
   case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
     Left m -> throwIO $ InsertException [ParseError $ T.pack m]

lib/Internal/Types/Main.hs

@@ -47,12 +47,14 @@ data DBState = DBState
   , kmBudgetInterval :: !DaySpan
   , kmStatementInterval :: !DaySpan
   , kmNewCommits :: ![Int]
-  , kmOldCommits :: ![Int]
+  }
-  , kmConfigDir :: !FilePath
+
-  , kmTagAll :: ![Entity TagR]
+data DBUpdates = DBUpdates
-  , kmAcntPaths :: ![AccountPathR]
+  { duOldCommits :: ![Int]
-  , kmAcntsOld :: ![Entity AccountR]
+  , duNewTagIds :: ![Entity TagR]
-  , kmCurrenciesOld :: ![Entity CurrencyR]
+  , duNewAcntPaths :: ![AccountPathR]
+  , duNewAcntIds :: ![Entity AccountR]
+  , duNewCurrencyIds :: ![Entity CurrencyR]
   }
 
 type CurrencyM = Reader CurrencyMap