pwncash/lib/Internal/Database.hs

module Internal.Database
  ( runDB
  , readConfigState
  , nukeTables
  , updateHashes
  , updateDBState
  -- , getDBState
  , tree2Records
  , flattenAcntRoot
  , indexAcntRoot
  , paths2IDs
  , mkPool
  , insertEntry
  , readUpdates
  , insertAll
  , updateTx
  )
where

import Conduit
import Control.Monad.Except
import Control.Monad.Logger
import Data.Decimal
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
  ( Statement
  , delete
  , deleteWhere
  , insert
  , insertKey
  , insert_
  , runMigration
  , update
  , (==.)
  , (||.)
  )
import GHC.Err
import Internal.Types.Main
import Internal.Utils
import RIO hiding (LogFunc, isNothing, on, (^.))
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
  :: 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

-- 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
--     (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
    go inA inBoth [] bs = (inA, inBoth, 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

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 => [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
    . fmap
      ( \e ->
          ( currencyRSymbol $ entityVal e
          , CurrencyPrec (entityKey e) $ fromIntegral $ currencyRPrecision $ entityVal e
          )
      )

toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
toKey = toSqlKey . fromIntegral . hash

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
    path = AcntPath atype (reverse $ name : parents)

tree2Records :: AcntType -> AccountTree -> ([Entity AccountR], [Entity AccountPathR])
tree2Records t = go []
  where
    go ps (Placeholder d n cs) =
      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 (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 ..]
    acnt n ps d = makeAccountEntity . makeAccountR t n ps d

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
    . first trimNames
    . L.unzip
    . 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 []
  where
    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)

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)
    ++ ((ExpenseT,) <$> arExpenses)
    ++ ((LiabilityT,) <$> arLiabilities)
    ++ ((AssetT,) <$> arAssets)
    ++ ((EquityT,) <$> arEquity)

makeAcntMap :: [Entity AccountR] -> AccountMap
makeAcntMap =
  M.fromList
    . paths2IDs
    . fmap go
    . filter (accountRLeaf . snd)
    . fmap (\e -> (E.entityKey e, E.entityVal e))
  where
    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)
--   => 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
     , PersistRecordBackend b SqlBackend
     )
  => 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)

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-select" (E.deleteKey q)

insertEntityManyE :: (MonadSqlQuery m, PersistRecordBackend a SqlBackend) => [Entity a] -> m ()
insertEntityManyE q = unsafeLiftSql "esqueleto-select" (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, 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)
  => [Int]
  -> m ([ReadEntry], [Either TotalUpdateEntrySet FullUpdateEntrySet])
readUpdates hashes = do
  xs <- selectE $ do
    (commits :& txs :& entrysets :& entries :& currencies) <-
      E.from
        $ E.table @CommitR
          `E.innerJoin` E.table @TransactionR
        `E.on` (\(c :& t) -> c ^. CommitRId ==. t ^. TransactionRCommit)
          `E.innerJoin` E.table @EntrySetR
        `E.on` (\(_ :& t :& es) -> t ^. TransactionRId ==. es ^. EntrySetRTransaction)
          `E.innerJoin` E.table @EntryR
        `E.on` (\(_ :& _ :& es :& e) -> es ^. EntrySetRId ==. e ^. EntryREntryset)
          `E.innerJoin` E.table @CurrencyR
        `E.on` (\(_ :& _ :& es :& _ :& cur) -> es ^. EntrySetRCurrency ==. cur ^. CurrencyRId)
    E.where_ $ commits ^. CommitRHash `E.in_` E.valList hashes
    return
      ( entrysets ^. EntrySetRRebalance
      ,
        (
          ( entrysets ^. EntrySetRId
          , txs ^. TransactionRDate
          , txs ^. TransactionRBudgetName
          , txs ^. TransactionRPriority
          ,
            ( entrysets ^. EntrySetRCurrency
            , currencies ^. CurrencyRPrecision
            )
          )
        , entries
        )
      )
  let (toUpdate, toRead) = L.partition (E.unValue . fst) xs
  toUpdate' <- liftExcept $ mapErrors makeUES $ groupKey (\(i, _, _, _, _) -> i) (snd <$> 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) $
                NE.sortWith (entryRIndex . snd) $
                  fmap (\e -> (entityKey e, entityVal e)) es
      case res of
        (Just froms, Just tos) -> do
          let tot = sum $ fmap (entryRValue . snd) froms
          (from0, fromRO, fromUnkVec) <- splitFrom prec' $ NE.reverse froms
          (from0', fromUnk, to0, toRO, toUnk) <- splitTo prec' from0 fromUnkVec tos
          -- TODO WAP (wet ass programming)
          return $ case from0' of
            Left x ->
              Left $
                UpdateEntrySet
                  { utDate = E.unValue day
                  , utCurrency = cur
                  , utFrom0 = x
                  , utTo0 = to0
                  , utFromRO = fromRO
                  , utToRO = toRO
                  , utFromUnk = fromUnk
                  , utToUnk = toUnk
                  , utTotalValue = realFracToDecimal prec' tot
                  , utBudget = E.unValue name
                  , utPriority = E.unValue pri
                  }
            Right x ->
              Right $
                UpdateEntrySet
                  { utDate = E.unValue day
                  , utCurrency = cur
                  , utFrom0 = x
                  , utTo0 = to0
                  , utFromRO = fromRO
                  , utToRO = toRO
                  , utFromUnk = fromUnk
                  , utToUnk = toUnk
                  , utTotalValue = ()
                  , utBudget = E.unValue name
                  , utPriority = E.unValue pri
                  }
        _ -> throwError undefined
    makeRE ((_, day, name, pri, (curID, prec)), entry) = do
      let e = entityVal entry
       in ReadEntry
            { reDate = E.unValue day
            , reCurrency = E.unValue curID
            , reAcnt = entryRAccount e
            , reValue = realFracToDecimal (fromIntegral $ E.unValue prec) (entryRValue e)
            , reBudget = E.unValue name
            , rePriority = E.unValue pri
            }

splitFrom
  :: Precision
  -> NonEmpty (EntryRId, EntryR)
  -> InsertExcept (Either UEBlank (Either UE_RO UEUnk), [UE_RO], [UEUnk])
splitFrom prec (f0 :| fs) = do
  -- ASSUME entries are sorted by index
  -- TODO combine errors here
  let f0Res = readDeferredValue prec f0
  let fsRes = mapErrors (splitDeferredValue prec) fs
  combineErrorM f0Res fsRes $ \f0' fs' -> do
    let (ro, unk) = partitionEithers fs'
    -- let idxVec = V.fromList $ fmap (either (const Nothing) Just) fs'
    return (f0', ro, unk)

splitTo
  :: Precision
  -> Either UEBlank (Either UE_RO UEUnk)
  -> [UEUnk]
  -> NonEmpty (EntryRId, EntryR)
  -> InsertExcept
      ( Either (UEBlank, [UELink]) (Either UE_RO (UEUnk, [UELink]))
      , [(UEUnk, [UELink])]
      , UEBlank
      , [UE_RO]
      , [UEUnk]
      )
splitTo prec from0 fromUnk (t0 :| ts) = do
  -- How to split the credit side of the database transaction in 1024 easy
  -- steps:
  --
  -- 1. Split incoming entries (except primary) into those with links and not
  let (unlinked, linked) = partitionEithers $ fmap splitLinked ts

  -- 2. For unlinked entries, split into read-only and unknown entries
  let unlinkedRes = partitionEithers <$> mapErrors (splitDeferredValue prec) unlinked

  -- 3. For linked entries, split into those that link to the primary debit
  --    entry and not
  let (linked0, linkedN) = second (groupKey id) $ L.partition ((== 0) . fst) linked

  -- 4. For linked entries that don't link to the primary debit entry, split
  --    into those that link to an unknown debit entry or not. Those that
  --    are not will be read-only and those that are will be collected with
  --    their linked debit entry
  let linkedRes = zipPaired prec fromUnk linkedN

  -- 5. For entries linked to the primary debit entry, turn them into linked
  --    entries (lazily only used when needed later)
  let from0Res = mapErrors (makeLinkUnk . snd) linked0

  combineErrorM3 from0Res linkedRes unlinkedRes $
    -- 6. Depending on the type of primary debit entry we have, add linked
    --    entries if it is either an unknown or a blank (to be solved) entry,
    --    or turn the remaining linked entries to read-only and add to the other
    --    read-only entries
    \from0Links (fromUnk', toROLinkedN) (toROUnlinked, toUnk) -> do
      let (from0', toROLinked0) = case from0 of
            Left blnk -> (Left (blnk, from0Links), [])
            Right (Left ro) -> (Right $ Left ro, makeRoUE prec . snd . snd <$> linked0)
            Right (Right unk) -> (Right $ Right (unk, from0Links), [])
      return (from0', fromUnk', primary, toROLinked0 ++ toROLinkedN ++ toROUnlinked, toUnk)
  where
    primary = uncurry makeUnkUE t0
    splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRCachedLink e

-- | Match linked credit entries with unknown entries, returning a list of
-- matches and non-matching (read-only) credit entries. ASSUME both lists are
-- sorted according to index and 'fst' respectively. NOTE the output will NOT be
-- sorted.
zipPaired
  :: Precision
  -> [UEUnk]
  -> [(Int, NonEmpty (EntryRId, EntryR))]
  -> InsertExcept ([(UEUnk, [UELink])], [UE_RO])
zipPaired prec = go ([], [])
  where
    nolinks = ((,[]) <$>)
    go acc fs [] = return $ first (nolinks fs ++) acc
    go (facc, tacc) fs ((ti, tls) : ts) = do
      let (lesser, rest) = L.span ((< ti) . ueIndex) fs
      links <- NE.toList <$> mapErrors makeLinkUnk tls
      let (nextLink, fs') = case rest of
            (r0 : rs)
              | ueIndex r0 == ti -> (Just (r0, links), rs)
              | otherwise -> (Nothing, rest)
            _ -> (Nothing, rest)
      let acc' = (nolinks lesser ++ facc, tacc)
      let ros = NE.toList $ makeRoUE prec . snd <$> tls
      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
    (throwError $ InsertException undefined)
    (return . makeUE k e . LinkScale)
    $ fromRational <$> entryRCachedValue e

splitDeferredValue :: Precision -> (EntryRId, EntryR) -> InsertExcept (Either UE_RO UEUnk)
splitDeferredValue prec p = do
  res <- readDeferredValue prec p
  case res of
    Left _ -> throwError $ InsertException undefined
    Right x -> return x

readDeferredValue :: Precision -> (EntryRId, EntryR) -> InsertExcept (Either UEBlank (Either UE_RO UEUnk))
readDeferredValue prec (k, e) = case (entryRCachedValue e, entryRCachedType e) of
  (Nothing, Just TFixed) -> return $ Right $ Left $ makeRoUE prec e
  (Just v, Just TBalance) -> go $ fmap EVBalance $ makeUE k e $ realFracToDecimal prec v
  (Just v, Just TPercent) -> go $ fmap EVPercent $ makeUE k e $ fromRational v
  (Nothing, Nothing) -> return $ Left $ makeUnkUE k e
  _ -> throwError $ InsertException undefined
  where
    go = return . Right . Right

makeUE :: i -> EntryR -> v -> UpdateEntry i v
makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)

makeRoUE :: Precision -> EntryR -> UpdateEntry () StaticValue
makeRoUE prec e = makeUE () e $ StaticValue (realFracToDecimal prec $ entryRValue e)

makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
makeUnkUE k e = makeUE k e ()

insertAll
  :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
  => [EntryBin]
  -> m ()
insertAll ebs = do
  (toUpdate, toInsert) <- balanceTxs ebs
  mapM_ updateTx toUpdate
  forM_ (groupWith itxCommit toInsert) $
    \(c, ts) -> 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
  mapM_ (uncurry (insertEntrySet k)) $ zip [0 ..] (NE.toList itxEntrySets)
  where
    insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do
      let fs = NE.toList iesFromEntries
      let ts = NE.toList iesToEntries
      let rebalance = any (isJust . ieDeferred) (fs ++ ts)
      esk <- insert $ EntrySetR tk iesCurrency i rebalance
      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
  i
  InsertEntry
    { ieEntry = Entry {eValue, eTags, eAcnt, eComment}
    , ieDeferred
    } =
    do
      ek <- insert $ EntryR k eAcnt eComment (toRational eValue) i cval ctype deflink
      mapM_ (insert_ . TagRelationR ek) eTags
      return ek
    where
      (cval, ctype, deflink) = case ieDeferred of
        (Just (DBEntryLinked x s)) -> (Just (toRational s), Nothing, Just $ fromIntegral x)
        (Just (DBEntryBalance b)) -> (Just (toRational b), Just TBalance, Nothing)
        (Just (DBEntryPercent p)) -> (Just (toRational p), Just TPercent, Nothing)
        Nothing -> (Nothing, Just TFixed, Nothing)

updateTx :: MonadSqlQuery m => UEBalanced -> m ()
updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. v]
  where
    v = toRational $ unStaticValue ueValue