pwncash/lib/Internal/Database.hs

module Internal.Database
  ( runDB
  , nukeTables
  , updateHashes
  , updateDBState
  , getDBState
  , tree2Records
  , flattenAcntRoot
  , paths2IDs
  , mkPool
  , whenHash0
  , whenHash
  , whenHash_
  , eitherHash
  , insertEntry
  , readUpdates
  , insertAll
  , updateTx
  )
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
  , update
  , (==.)
  , (||.)
  )
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 NE
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
          , CurrencyPrec (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) = NE.reverse $ atName t :| ns

-- 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

(!?) :: 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)

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

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

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)
  return (makeRE . snd <$> toRead, toUpdate')
  where
    makeUES ((_, day, name, pri, (curID, prec)), es) = do
      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 $ NE.reverse froms
          (from0', fromUnk, to0, toRO, toUnk) <- splitTo from0 fromUnkVec tos
          -- TODO WAP (wet ass programming)
          return $ case from0' of
            Left x ->
              Left $
                UpdateEntrySet
                  { utDate = E.unValue day
                  , utCurrency = (E.unValue curID, fromIntegral $ E.unValue prec)
                  , utFrom0 = x
                  , utTo0 = to0
                  , utFromRO = fromRO
                  , utToRO = toRO
                  , utFromUnk = fromUnk
                  , utToUnk = toUnk
                  , utTotalValue = tot
                  , utBudget = E.unValue name
                  , utPriority = E.unValue pri
                  }
            Right x ->
              Right $
                UpdateEntrySet
                  { utDate = E.unValue day
                  , utCurrency = (E.unValue curID, fromIntegral $ E.unValue prec)
                  , 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, _)), entry) =
      let e = entityVal entry
       in ReadEntry
            { reDate = E.unValue day
            , reCurrency = E.unValue curID
            , reAcnt = entryRAccount e
            , reValue = entryRValue e
            , reBudget = E.unValue name
            , rePriority = E.unValue pri
            }

splitFrom
  :: NonEmpty (EntryRId, EntryR)
  -> InsertExcept (Either UEBlank (Either UE_RO UEUnk), [UE_RO], [UEUnk])
splitFrom (f0 :| fs) = do
  -- ASSUME entries are sorted by index
  -- TODO combine errors here
  let f0Res = readDeferredValue f0
  let fsRes = mapErrors splitDeferredValue 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
  :: 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 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 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 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 . 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
  :: [UEUnk]
  -> [(Int, NonEmpty (EntryRId, EntryR))]
  -> InsertExcept ([(UEUnk, [UELink])], [UE_RO])
zipPaired = 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 . 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)
    $ entryRCachedValue e

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

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

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

makeRoUE :: EntryR -> UpdateEntry () StaticValue
makeRoUE e = makeUE () e $ StaticValue (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 eValue i cval ctype deflink
      mapM_ (insert_ . TagRelationR ek) eTags
      return ek
    where
      (cval, ctype, deflink) = case ieDeferred of
        (Just (EntryLinked index scale)) -> (Just scale, Nothing, Just $ fromIntegral index)
        (Just (EntryBalance target)) -> (Just target, Just TBalance, Nothing)
        (Just (EntryPercent target)) -> (Just target, Just TPercent, Nothing)
        Nothing -> (Nothing, Just TFixed, Nothing)

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